home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / plplot / plplot_2 / drivers / tk / pltools.tc < prev    next >
Encoding:
Text File  |  1994-07-01  |  20.6 KB  |  714 lines
  1. # $Id: pltools.tcl,v 1.13 1994/07/01 20:39:57 mjl Exp $
  2. # $Log: pltools.tcl,v $
  3. # Revision 1.13  1994/07/01  20:39:57  mjl
  4. # Added proc plstdwin to handle "standard" initialization code.
  5. #
  6. # Revision 1.12  1994/04/25  18:58:48  mjl
  7. # Added the simple class system by Sam Shen for support of the palette
  8. # manipulators.  Will probably rewrite in itcl at some point.
  9.  
  10. #----------------------------------------------------------------------------
  11. # PLPLOT TK/TCL graphics renderer support procs
  12. # Maurice LeBrun
  13. # 1-Jul-1993
  14. # IFS, University of Texas at Austin
  15. #
  16. # Includes code borrowed from the TCL/TK widget demo.
  17. #----------------------------------------------------------------------------
  18.  
  19. #----------------------------------------------------------------------------
  20. # plstdwin
  21. #
  22. # Does "standard" startup for a plframe-containing main window.
  23. # Use it or roll your own, but note: this may change in future versions.
  24. #----------------------------------------------------------------------------
  25.  
  26. proc plstdwin {w} {
  27.     global plstdwin_skip_startup
  28.  
  29. # Only do global initialization once.
  30.  
  31.     if { ! [info exists plstdwin_skip_startup]} {
  32.  
  33. # Set up configuration options.
  34. # The first is to hold default values of everything, the second is for
  35. # user customization.  See pldefaults.tcl for more info.
  36.  
  37.     pldefaults
  38.     plconfig
  39.  
  40. # I refuse to allow exec's since there's no need for them now.
  41. # Open's have to remain, however, to read/write palette info.
  42.  
  43.     rename exec {}
  44.  
  45.     set plstdwin_skip_startup 1
  46.     }
  47.  
  48. # Set min/max window sizes.
  49.  
  50.     set root_width  [winfo vrootwidth .] 
  51.     set root_height [winfo vrootheight .]
  52.  
  53.     wm minsize $w 300 240
  54.     wm maxsize $w [expr "$root_width/64*63"] [expr "$root_height/64*62"]
  55.  
  56. # Set window geometry defaults.  Depart from square slightly to account
  57. # for menu bar.
  58.  
  59.     global geometry
  60.     if { ! [ info exists geometry ] } then {
  61.     set width  [expr "$root_width / 16 * 10"]
  62.     set height [expr "$root_height / 16 * 11"]
  63.     set geometry ${width}x${height}
  64.     }
  65.     wm geometry $w $geometry
  66. }
  67.  
  68. #----------------------------------------------------------------------------
  69. # null_command
  70. #
  71. # Invokes a dialog explaining that the real binding isn't written yet.
  72. #----------------------------------------------------------------------------
  73.  
  74. proc null_command {cmd_name} {
  75.     set dialog_args "-text {Command \"$cmd_name\" not yet implemented.} \
  76.              -aspect 500 -justify left"
  77.     mkDialog .null $dialog_args {OK {}}
  78.     tkwait visibility .null
  79.     grab .null
  80.     tkwait window .null
  81. }
  82.  
  83. #----------------------------------------------------------------------------
  84. # bogue_out
  85. #
  86. # Invokes a dialog explaining that the user bogued out (messed up, blew
  87. # it, puked on the system console, etc).
  88. #----------------------------------------------------------------------------
  89.  
  90. proc bogue_out {msg} {
  91.     set dialog_args "-text \"$msg\" -aspect 800 -justify left"
  92.     mkDialog .bogus $dialog_args {OK {}}
  93.     tkwait visibility .bogus
  94.     grab .bogus
  95.     focus .bogus
  96.     tkwait window .bogus
  97. }
  98.  
  99. #----------------------------------------------------------------------------
  100. # dpos w
  101. #
  102. # Position a dialog box at a reasonable place on the screen.
  103. #----------------------------------------------------------------------------
  104.  
  105. proc dpos w {
  106.     set offx [expr "[winfo rootx .]+100"]
  107.     set offy [expr "[winfo rooty .]+100"]
  108.     wm geometry $w +$offx+$offy
  109. }
  110.  
  111. #----------------------------------------------------------------------------
  112. # normal_text_setup
  113. #
  114. # Sets up text widgets the way I like them.
  115. #----------------------------------------------------------------------------
  116.  
  117. proc normal_text_setup {w {width 60} {height 30}} {
  118.     global dialog_font dialog_bold_font
  119.  
  120.     button $w.ok -text OK -command "destroy $w"
  121.     text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \
  122.         -width $width -height $height
  123.     scrollbar $w.s -relief flat -command "text_scroll $w.t"
  124.     pack append $w $w.ok {bottom fillx} $w.s {right filly} $w.t {expand fill}
  125.     focus $w.t
  126.  
  127. # Set up display styles
  128.  
  129.     $w.t tag configure normal -font $dialog_font
  130.     $w.t tag configure bold -font $dialog_bold_font
  131.  
  132.     if {[tk colormodel $w] == "color"} {
  133.     $w.t tag configure color1 -background #eed5b7
  134.     $w.t tag configure color2 -foreground red
  135.     $w.t tag configure raised -background #eed5b7 -relief raised \
  136.         -borderwidth 1
  137.     $w.t tag configure sunken -background #eed5b7 -relief sunken \
  138.         -borderwidth 1
  139.     } else {
  140.     $w.t tag configure color1 -background black -foreground white
  141.     $w.t tag configure color2 -background black -foreground white
  142.     $w.t tag configure raised -background white -relief raised \
  143.         -borderwidth 1
  144.     $w.t tag configure sunken -background white -relief sunken \
  145.         -borderwidth 1
  146.     }
  147.     $w.t tag configure bgstipple -background black -borderwidth 0 \
  148.         -bgstipple gray25
  149.     $w.t tag configure fgstipple -fgstipple gray50
  150.     $w.t tag configure underline -underline on
  151.  
  152. # Set up bindings to be as useful as possible.
  153.  
  154.     bind $w <Any-Enter> "focus $w.t"
  155.  
  156.     bind $w.t <Return>      "destroy $w"
  157.  
  158.     bind $w.t <Down>      "text_scroll_by_line $w.t + 1"
  159.     bind $w.t <Up>      "text_scroll_by_line $w.t - 1"
  160.  
  161.     bind $w.t <Next>      "text_scroll_by_page $w.t + 1"
  162.     bind $w.t <space>      "text_scroll_by_page $w.t + 1"
  163.  
  164.     bind $w.t <Prior>      "text_scroll_by_page $w.t - 1"
  165.     bind $w.t <BackSpace> "text_scroll_by_page $w.t - 1"
  166.     bind $w.t <Delete>      "text_scroll_by_page $w.t - 1"
  167. }
  168.  
  169. #----------------------------------------------------------------------------
  170. # text_scroll
  171. #
  172. # Scrolls text widget vertically, updating various things
  173. #----------------------------------------------------------------------------
  174.  
  175. proc text_scroll {w line} {
  176.     $w yview $line
  177.     $w mark set insert [$w index @0,0]
  178. }
  179.  
  180. #----------------------------------------------------------------------------
  181. # text_scroll_by_line
  182. #
  183. # Scrolls text widget vertically by the given number of lines.
  184. #----------------------------------------------------------------------------
  185.  
  186. proc text_scroll_by_line {w sign delta} {
  187.     text_scroll $w [$w index "@0,0 $sign $delta lines"]
  188. }
  189.  
  190. #----------------------------------------------------------------------------
  191. # text_scroll_by_page
  192. #
  193. # Scrolls text widget vertically by the given number of pages (almost).
  194. #----------------------------------------------------------------------------
  195.  
  196. proc text_scroll_by_page {w sign delta} {
  197.     set height [lindex [$w config -height] 4]
  198.     set delta [expr $delta*($height-2)]
  199.     text_scroll $w [$w index "@0,0 $sign $delta lines"]
  200. }
  201.  
  202. #----------------------------------------------------------------------------
  203. # The procedure below inserts text into a given text widget and
  204. # applies one or more tags to that text.  The arguments are:
  205. #
  206. # w        Window in which to insert
  207. # text        Text to insert (it's inserted at the "insert" mark)
  208. # args        One or more tags to apply to text.  If this is empty
  209. #        then all tags are removed from the text.
  210. #----------------------------------------------------------------------------
  211.  
  212. proc insertWithTags {w text args} {
  213.     set start [$w index insert]
  214.     $w insert insert $text
  215.     foreach tag [$w tag names $start] {
  216.     $w tag remove $tag $start insert
  217.     }
  218.     foreach i $args {
  219.     $w tag add $i $start insert
  220.     }
  221. }
  222.  
  223. #----------------------------------------------------------------------------
  224. # Numeric utility procs:
  225. #
  226. #    min    returns minimum argument
  227. #    max    returns maximum argument
  228. #
  229. # Taken from utils.tcl by Tom Phelps (phelps@cs.Berkeley.EDU)
  230. #----------------------------------------------------------------------------
  231.  
  232. proc min {args} {
  233.    set x [lindex $args 0]
  234.    foreach i $args {
  235.       if {$i<$x} {set x $i}
  236.    }
  237.    return $x
  238. }
  239.  
  240. proc max {args} {
  241.    set x [lindex $args 0]
  242.    foreach i $args {
  243.       if {$i>$x} {set x $i}
  244.    }
  245.    return $x
  246. }
  247.  
  248. #----------------------------------------------------------------------------
  249. # getItem
  250. #
  251. # Asks user to input something, returning the result.
  252. # Selecting "Cancel" returns the empty string.
  253. #----------------------------------------------------------------------------
  254.  
  255. proc getItem {item} {
  256.     global dialog_font dialog_bold_font
  257.     global itemval
  258.  
  259.     set w .entry
  260.     set itemval ""
  261.  
  262.     catch {destroy $w}
  263.     toplevel $w
  264.     dpos $w
  265.     wm title $w "Entry"
  266.     wm iconname $w "Entry"
  267.     message $w.msg -font $dialog_font -aspect 800 -text $item
  268.  
  269.     frame $w.frame -borderwidth 10
  270.     pack append $w.frame \
  271.     [entry $w.frame.e1 -relief sunken] {top pady 10 fillx} 
  272.  
  273.     button $w.ok -text OK -command \
  274.     "set itemval \[$w.frame.e1 get\]; destroy $w"
  275.     button $w.cancel -text Cancel -command "destroy $w"
  276.  
  277.     bind $w.frame.e1 <Return> \
  278.     "set itemval \[$w.frame.e1 get\]; destroy $w"
  279.  
  280.     pack append $w $w.msg {top fill} $w.frame {top expand fill} \
  281.     $w.ok {left expand fill} $w.cancel {left expand fill}
  282.  
  283.     tkwait visibility $w
  284.     grab $w
  285.     focus $w.frame.e1
  286.     tkwait window $w
  287.     return $itemval
  288. }
  289.  
  290. #----------------------------------------------------------------------------
  291. # confirm
  292. #
  293. # Sure about that, buddy?
  294. #----------------------------------------------------------------------------
  295.  
  296. proc confirm {msg} {
  297.     global confirm_flag
  298.     set dialog_args "-text {$msg} \
  299.              -aspect 500 -justify left"
  300.     mkDialog .confirm $dialog_args \
  301.     "OK {set confirm_flag 1}" "Cancel {set confirm_flag 0}"
  302.     tkwait visibility .confirm
  303.     grab .confirm
  304.     focus .confirm
  305.     tkwait window .confirm
  306.     return $confirm_flag
  307. }
  308.  
  309. #----------------------------------------------------------------------------
  310. # mkDialog w msgArgs list list ...
  311. #
  312. # Create a dialog box with a message and any number of buttons at
  313. # the bottom.
  314. #
  315. # Arguments:
  316. #    w -    Name to use for new top-level window.
  317. #    msgArgs -    List of arguments to use when creating the message of the
  318. #        dialog box (e.g. text, justifcation, etc.)
  319. #    list -    A two-element list that describes one of the buttons that
  320. #        will appear at the bottom of the dialog.  The first element
  321. #        gives the text to be displayed in the button and the second
  322. #        gives the command to be invoked when the button is invoked.
  323. #----------------------------------------------------------------------------
  324.  
  325. proc mkDialog {w msgArgs args} {
  326.     catch {destroy $w}
  327.     toplevel $w -class Dialog
  328.     dpos $w
  329.     wm title $w "Dialog box"
  330.     wm iconname $w "Dialog"
  331.  
  332.     # Create two frames in the main window. The top frame will hold the
  333.     # message and the bottom one will hold the buttons.  Arrange them
  334.     # one above the other, with any extra vertical space split between
  335.     # them.
  336.  
  337.     frame $w.top -relief raised -border 1
  338.     frame $w.bot -relief raised -border 1
  339.     pack append $w $w.top {top fill expand} $w.bot {top fill expand}
  340.     
  341.     # Create the message widget and arrange for it to be centered in the
  342.     # top frame.
  343.     
  344.     eval message $w.top.msg -justify center $msgArgs
  345.     pack append $w.top $w.top.msg {top expand padx 10 pady 10}
  346.     
  347.     # Create as many buttons as needed and arrange them from left to right
  348.     # in the bottom frame.  Embed the left button in an additional sunken
  349.     # frame to indicate that it is the default button, and arrange for that
  350.     # button to be invoked as the default action for clicks and returns in
  351.     # the dialog.
  352.  
  353.     if {[llength $args] > 0} {
  354.     set arg [lindex $args 0]
  355.     frame $w.bot.0 -relief sunken -border 1
  356.     pack append $w.bot $w.bot.0 {left expand padx 20 pady 20}
  357.     button $w.bot.0.button -text [lindex $arg 0] \
  358.         -command "[lindex $arg 1]; destroy $w"
  359.     pack append $w.bot.0 $w.bot.0.button {expand padx 12 pady 12}
  360.     bind $w <Return> "[lindex $arg 1]; destroy $w"
  361.     focus $w
  362.  
  363.     set i 1
  364.     foreach arg [lrange $args 1 end] {
  365.         button $w.bot.$i -text [lindex $arg 0] \
  366.             -command "[lindex $arg 1]; destroy $w"
  367.         pack append $w.bot $w.bot.$i {left expand padx 20}
  368.         set i [expr $i+1]
  369.     }
  370.     }
  371.     bind $w <Any-Enter> [list focus $w]
  372.     focus $w
  373. }
  374.  
  375. #----------------------------------------------------------------------------
  376. # Form2d
  377. #
  378. # Create a top-level window that displays a bunch of entries used for
  379. # entering window coordinates.
  380. #
  381. # Arguments:
  382. #    w        Name of top level window
  383. #    desc    Short description of coordinates to be entered.
  384. #
  385. # Global variables referenced:
  386. #    fv00    fn00
  387. #    fv01    fn01
  388. #    fv10    fn10
  389. #    fv11    fn11
  390. #
  391. # The global variables are modified by the entry widgets and may be
  392. # overwritten at any time so the caller must wait for the dialog to be
  393. # destroyed and then use them immediately.  
  394. #----------------------------------------------------------------------------
  395.  
  396. proc Form2d {w desc} {
  397.     global dialog_font dialog_bold_font
  398.     global tabList
  399.     global fv00 fv01 fv10 fv11
  400.     global fn00 fn01 fn10 fn11
  401.  
  402.     catch {destroy $w}
  403.     toplevel $w
  404.     dpos $w
  405.  
  406.     wm title $w "Entry window"
  407.     wm iconname $w "Entry"
  408.  
  409.     message $w.msg \
  410.     -font $dialog_font \
  411.     -aspect 700 \
  412.     -text "$desc  Click \"OK\" button when finished."
  413.  
  414.     pack append $w \
  415.     $w.msg {top fill}
  416.  
  417.     set rows {0 1}
  418.     set cols {0 1}
  419.     set tabList ""
  420.  
  421.     foreach i $rows {
  422.     frame $w.$i
  423.  
  424.     foreach j $cols {
  425.             set name [set fn$i$j]
  426.             set value [set fv$i$j]
  427.         frame $w.$i.$j -bd 1m
  428.  
  429.         entry $w.$i.$j.entry -relief sunken -width 10
  430.         $w.$i.$j.entry insert 0 $value
  431.         bind $w.$i.$j.entry <Tab> "Form2d_tab \$tabList"
  432.         bind $w.$i.$j.entry <Return> "Form2d_destroy $w"
  433.             set tabList [concat $tabList $w.$i.$j.entry]
  434.  
  435.         label $w.$i.$j.label -width 10
  436.         $w.$i.$j.label config -text "$name:"
  437.  
  438.         pack append $w.$i.$j \
  439.         $w.$i.$j.entry right \
  440.         $w.$i.$j.label left
  441.  
  442.         pack append $w.$i \
  443.         $w.$i.$j {left fillx}
  444.     }
  445.  
  446.     pack append $w \
  447.         $w.$i {top fillx} 
  448.     }
  449.  
  450.     button $w.ok -text OK -command "Form2d_destroy $w"
  451.     pack append $w \
  452.     $w.ok {bottom fill}
  453.  
  454.     tkwait visibility $w
  455.     grab $w
  456.     focus $w.0.0.entry
  457. }
  458.  
  459. # This procedure is invoked when the top level entry dialog is destroyed.
  460. # It updates the global vars used to communicate the entry values then
  461. # destroys the window.
  462.  
  463. proc Form2d_destroy {w} {
  464.     global fv00 fv01 fv10 fv11
  465.  
  466.     set fv00 [$w.0.0.entry get]
  467.     set fv01 [$w.0.1.entry get]
  468.     set fv10 [$w.1.0.entry get]
  469.     set fv11 [$w.1.1.entry get]
  470.  
  471.     destroy $w
  472. }
  473.  
  474. # The procedure below is invoked in response to tabs in the entry
  475. # windows.  It moves the focus to the next window in the tab list.
  476. # Arguments:
  477. #
  478. # list -    Ordered list of windows to receive focus
  479.  
  480. proc Form2d_tab {list} {
  481.     set i [lsearch $list [focus]]
  482.     if {$i < 0} {
  483.     set i 0
  484.     } else {
  485.     incr i
  486.     if {$i >= [llength $list]} {
  487.         set i 0
  488.     }
  489.     }
  490.     focus [lindex $list $i]
  491. }
  492.  
  493. #----------------------------------------------------------------------------
  494. # evalCmd w
  495. #
  496. # Create a top-level window containing a text widget that allows you
  497. # to enter a TCL command and have it executed.
  498. #
  499. # Arguments:
  500. #    w -    Name to use for new top-level window.
  501. #----------------------------------------------------------------------------
  502.  
  503. proc evalCmd {{w .eval}} {
  504.     catch {destroy $w}
  505.     toplevel $w -geometry 400x300
  506.     dpos $w
  507.     wm title $w "Interpret command"
  508.     wm iconname $w "Interpret"
  509.  
  510.     frame $w.cmd
  511.     label $w.cmd.label -text "Command:" -width 13 -anchor w
  512.     entry $w.cmd.entry -width 40 -relief sunken -bd 2 -textvariable command
  513.     button $w.cmd.button -text "Execute" \
  514.         -command "eval \$command"
  515.     pack append $w.cmd $w.cmd.label left $w.cmd.entry left \
  516.         $w.cmd.button {left pady 10 padx 20}
  517.     bind $w.cmd.entry <Return> "eval \$command"
  518.  
  519.     text $w.t -relief raised -bd 2 -setgrid true
  520.     $w.t insert 0.0 {\
  521. Type TCL command to be executed in the window above, then type <Return>
  522. or click on "Execute".  
  523. }
  524.     $w.t mark set insert 0.0
  525.     bind $w <Any-Enter> "focus $w.cmd.entry"
  526.  
  527.     button $w.ok -text OK -command "destroy $w"
  528.  
  529.     pack append $w $w.cmd {top fill} \
  530.         $w.ok {bottom fillx} $w.t {expand fill}
  531. }
  532.  
  533. #------------------------------------------------------------------------------
  534. #
  535. # A simple class system in Tcl.
  536. #
  537. # From the pixmap editor by Sam Shen (sls@aero.org)
  538. #
  539. #------------------------------------------------------------------------------
  540.  
  541. set object_counter 0
  542. proc class {class_name spec} {
  543.     global class_methods
  544.     set members ""
  545.     for {set i 0} {$i < [llength $spec]} {incr i} {
  546.     case [lindex $spec $i] {
  547.         method {
  548.         set method_body [concat global \$this ";" in \$this]
  549.         lappend method_body [lindex $spec [expr {$i+3}]]
  550.         set ag [linsert [lindex $spec [expr {$i+2}]] 0 this]
  551.         proc $class_name:[lindex $spec [expr {$i+1}]] \
  552.             $ag $method_body
  553.         lappend class_methods($class_name) [lindex $spec [expr {$i+1}]]
  554.         incr i 3
  555.         }
  556.         member {
  557.         lappend members [list [lindex $spec [expr {$i+1}]] \
  558.                  [lindex $spec [expr {$i+2}]]]
  559.         incr i 2
  560.         }
  561.         "#|" {
  562.         incr i
  563.         while {[lindex $spec $i] != "#|"} {
  564.             incr i
  565.         }
  566.         }
  567.         default {
  568.         error [format {unknown keyword "%s" in class declaration} \
  569.                [lindex $spec $i]]
  570.         }
  571.     }
  572.     }
  573.     if {$members != ""} {
  574.     set ctor_body [format {
  575.         upvar #0 $_this this
  576.         foreach member {%s} {
  577.         set this([lindex $member 0]) [lindex $member 1]
  578.         }
  579.     } $members]
  580.     proc $class_name:Construct _this $ctor_body
  581.     }
  582.     set body [format {
  583.     global object_counter
  584.     set objects ""
  585.     for {set i 0} {$i < $count} {incr i} {
  586.         set var O_[incr object_counter]
  587.         upvar #0 $var object
  588.         lappend objects $var
  589.         set object(class) %s
  590.         if %d {
  591.         uplevel "%s:Construct $var"
  592.         }
  593.     }
  594.     return $objects
  595.     } $class_name [expr {$members != ""}] $class_name]
  596.     proc $class_name {{count 1}} $body
  597. }
  598.  
  599. set in_counter 0
  600. set in_sti 0
  601. proc push_scope {on} {
  602.     global in_sti in_st
  603.     set in_st([incr in_sti]) $on
  604. }
  605. proc in_scope? {on} {
  606.     global in_sti in_st
  607.     expr {$in_sti > 0 && $in_st($in_sti) == $on}
  608. }
  609. proc pop_scope {} {
  610.     global in_sti in_st
  611.     unset in_st($in_sti)
  612.     incr in_sti -1
  613. }
  614.  
  615. proc in {_object expr} {
  616.     upvar #0 $_object object
  617.     global in_counter errorInfo class_methods
  618.     set cleanup ""
  619.     if ![in_scope? $_object] {
  620.     push_scope $_object
  621.     set switched_scope 1
  622.     set ctr [incr in_counter]
  623.     set cleanup "pop_scope; "
  624.     set class $object(class)
  625.     foreach method $class_methods($class) {
  626.         if {[info procs $method] != ""} {
  627.         set oldproc $method[set ctr]
  628.         rename $method $oldproc
  629.         append cleanup "rename $method {}; rename $oldproc $method; "
  630.         } else {
  631.         append cleanup "rename $method {}; "
  632.         }
  633.         set method_body [format {
  634.         uplevel [format "%s %s %%s" $args]
  635.         } $class:$method $_object]
  636.         proc $method args $method_body
  637.     }
  638.     }
  639.     if {[set retval [catch {uplevel $expr} result]] == 1} {
  640.     set savedInfo $errorInfo
  641.     }
  642.     eval $cleanup
  643.     if {$retval == 1} {
  644.     error $result $savedInfo
  645.     }
  646.     return $result
  647. }
  648.  
  649. proc getmember var {
  650.     upvar [uplevel "set this"] o
  651.     set o($var)
  652. }
  653.  
  654. proc setmember {var val} {
  655.     set cmd [format {set [set this](%s)} $var]
  656.     lappend cmd $val
  657.     return [uplevel $cmd]
  658. }
  659.  
  660. proc appendmember {var val} {
  661.     set cmd [format {append [set this](%s)} $var]
  662.     lappend cmd $val
  663.     uplevel $cmd
  664. }
  665.  
  666. proc membername {var} {
  667.     set o [uplevel {set this}]
  668.     return [format %s(%s) $o $var]
  669. }
  670.  
  671. proc lappendmember {var val} {
  672.     set cmd [format {lappend [set this](%s)} $var]
  673.     lappend cmd $val
  674.     uplevel $cmd
  675. }
  676.  
  677. proc delete object {
  678.     uplevel "unset $object"
  679. }
  680.  
  681. #------------------------------------------------------------------------------
  682. # Proc to set up debug bindings.
  683. #------------------------------------------------------------------------------
  684.  
  685. proc dbug_bind {w} {
  686.  
  687. bind $w <Any-ButtonPress>    {puts stderr "Widget event: ButtonPress"}
  688. bind $w <Any-ButtonRelease>    {puts stderr "Widget event: ButtonRelease"}
  689. bind $w <Any-Circulate>        {puts stderr "Widget event: Circulate"}
  690. bind $w <Any-CirculateRequest>    {puts stderr "Widget event: CirculateRequest"}
  691. bind $w <Any-Colormap>        {puts stderr "Widget event: Colormap"}
  692. bind $w <Any-Configure>        {puts stderr "Widget event: Configure"}
  693. bind $w <Any-ConfigureRequest>    {puts stderr "Widget event: ConfigureRequest"}
  694. bind $w <Any-Destroy>        {puts stderr "Widget event: Destroy"}
  695. bind $w <Any-Enter>        {puts stderr "Widget event: Enter"}
  696. bind $w <Any-Expose>         {puts stderr "Widget event: Expose"}
  697. bind $w <Any-FocusIn>        {puts stderr "Widget event: FocusIn"}
  698. bind $w <Any-FocusOut>        {puts stderr "Widget event: FocusOut"}
  699. bind $w <Any-Gravity>        {puts stderr "Widget event: Gravity"}
  700. bind $w <Any-Keymap>        {puts stderr "Widget event: Keymap"}
  701. bind $w <Any-KeyPress>        {puts stderr "Widget event: KeyPress"}
  702. bind $w <Any-KeyRelease>    {puts stderr "Widget event: KeyRelease"}
  703. bind $w <Any-Leave>        {puts stderr "Widget event: Leave"}
  704. bind $w <Any-Map>        {puts stderr "Widget event: Map"}
  705. bind $w <Any-MapRequest>    {puts stderr "Widget event: MapRequest"}
  706. #bind $w <Any-Motion>        {puts stderr "Widget event: Motion"}
  707. bind $w <Any-Property>        {puts stderr "Widget event: Property"}
  708. bind $w <Any-Reparent>        {puts stderr "Widget event: Reparent"}
  709. bind $w <Any-ResizeRequest>    {puts stderr "Widget event: ResizeRequest"}
  710. bind $w <Any-Unmap>        {puts stderr "Widget event: Unmap"}
  711. bind $w <Any-Visibility>    {puts stderr "Widget event: Visibility"}
  712.  
  713. }
  714.