File library/command.tcl artifact d6fcf183f1 part of check-in 424c69792c

# command.tcl --
#
# This file defines the CTk command dialog procedure.
#
# @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $
#
# Copyright (c) 1995 Cleveland Clinic Foundation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

proc ctk_menu {} {
    if ![winfo exists .ctkMenu] {
	menu .ctkMenu
	.ctkMenu add command -label "Command.." -underline 0 -command ctkDialog
	.ctkMenu add command -label "Next" -underline 0\
		-command {ctkNextTop [focus]}
	.ctkMenu add command -label "Redraw" -underline 0\
		-command {ctk redraw .ctkMenu}
	.ctkMenu add command -label "Exit" -underline 1 -command exit
    }
    tk_popup .ctkMenu 0 0 0
}

proc ctkDialog {} {ctkCommand .ctkDlg}

# ctkCommand --
#
proc ctkCommand w {
    if [winfo exists $w] {
    	wm deiconify $w
	raise $w
    } else {
	toplevel $w -class Dialog -width 30 -height 10
	wm title $w Command
	entry $w.entry
	text $w.output -state disabled -takefocus 1
	button $w.close -command "destroy $w" -text Close

	pack $w.entry -side top -fill x
	pack $w.output -side top -fill both -expand 1
	pack $w.close -side bottom

	bind $w.entry <Return> "ctkCommandRun $w; break"
	bind $w <Cancel> "destroy $w"
    }
    focus $w.entry
    tkwait window $w
}

proc ctkCommandRun w {
    global errorInfo
    set code [catch {uplevel #0 [$w.entry get]} result]
    $w.output configure -state normal
    $w.output delete 1.0 end
    $w.output insert 1.0 $result
    if $code  { $w.output insert end "\n----\n$errorInfo" }
    $w.output mark set insert 1.0
    $w.output configure -state disabled
    $w.entry delete 0 end
}