home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / menu.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  5.3 KB  |  188 lines

  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # These commands are called via the menubar.  The goal is to have all
  8. # "-command" options of widgets and menus (and bindings) consist entirely
  9. # of procedure calls with aruments, so we can create test cases in batch
  10. # files by simulating events and button/menu invocations
  11.  
  12. # toggle the grid lines
  13.  
  14. proc toggle_grid {} {
  15.     global Frames Grid
  16.     foreach i [array names Frames] {
  17.         grid_resize $i $Grid
  18.         update_table $i grid
  19.         }
  20.     }
  21.  
  22. # Copy the selected widget to the clipboard
  23.  
  24. proc to_clipboard {} {
  25.     global Current _Message
  26.     if {$Current(widget) != ""} {
  27.         upvar #0 [winfo name $Current(widget)] data
  28.         set append "array set SpecTcl_widget \{"
  29.         foreach i [array names data] {
  30.             lappend append $i $data($i)
  31.         }
  32.         append append \}
  33.         clipboard clear
  34.         clipboard append $append
  35.         set _Message "Copying $data(item_name) to clipboard"
  36.     }
  37. }
  38.  
  39. # paste the clipboard item into the current canvas (gulp)
  40. # This is still broken
  41.  
  42. proc from_clipboard {{test 0}} {
  43.     global Current SpecTcl_widget Next_widget
  44.     if {!$test} {global _Message}
  45.  
  46.     if {[catch {set widget [selection get -selection CLIPBOARD]}]} {
  47.         set _Message "No data on clipboard"
  48.         return 0
  49.     }
  50.     if {![regexp SpecTcl_widget $widget] || [catch {eval $widget}]} {
  51.         set _Message "Invalid data on clipboard"
  52.         return 0
  53.     }    
  54.  
  55.     if {$test} {return 1}
  56.  
  57.     # change the appopriate widget parameters and put the
  58.     # widget in a "hidden" spot
  59.  
  60.     set type $SpecTcl_widget(type)
  61.     set name $SpecTcl_widget(item_name)
  62.  
  63.     # for consistency with copy
  64.     set SpecTcl_widget(rowspan) 1
  65.     set SpecTcl_widget(columnspan) 1
  66.  
  67.     set SpecTcl_widget(row) 0
  68.     set SpecTcl_widget(column) 0
  69.     set SpecTcl_widget(master) ""
  70.     catch {destroy .clipboard}
  71.     frame .clipboard
  72.     set new [widget_configure SpecTcl_widget .clipboard]
  73.  
  74.     # figure out where to put it
  75.     # 1) if a widget is selected, delete it and put new one there
  76.     # 2) if a row and column are selected, put it there
  77.     # 3) if a row or column is selected, put in first empty cell (later)
  78.     # 4) punt
  79.  
  80.     if {$Current(widget) != ""} {
  81.         scan [blt_table info $Current(widget)] "%*s %d,%d" row col
  82.         delete_selected 0
  83.     } elseif {$Current(row) != "" && $Current(column) != ""} {
  84.         regsub {[^_]*_} $Current(row) {} row
  85.         regsub {[^_]*_} $Current(column) {} col
  86.         if {[blt_table slaves $Current(frame) -row $row -column $col] != ""} {
  87.             set _Message "Selected position is already occupied"
  88.             return 0
  89.         }
  90.     } else {
  91.         set _Message "No where to put widget!"
  92.         return 0
  93.     }
  94.     set win [copy_widget $Current(frame) $new $row,$col]
  95.     set_master $win $Current(frame)
  96.     upvar #0 [winfo name $win] data
  97.     if {!([regexp # $name] || [have_name $name])} {
  98.         set data(item_name) $name
  99.     }
  100.     unselect_widget
  101.     select_widget $win
  102.     destroy .clipboard    
  103.     set _Message "Pasting $data(item_name)"
  104. }
  105.  
  106. # bring up generic menu option sheet affiliated with selected widget
  107.  
  108. proc menu_generic {} {
  109.     global Current _Message
  110.     if {$Current(widget) != ""} {
  111.         upvar #0 [winfo name $Current(widget)] data
  112.         activate_generic $data(type)
  113.     } else {
  114.         set _Message "No widget is selected"
  115.         bell
  116.     }
  117. }
  118.  
  119. # bring up widget menu option sheet
  120.  
  121. proc menu_widget {} {
  122.     global Current _Message
  123.     if {$Current(widget) != ""} {
  124.         upvar #0 [winfo name $Current(widget)] data
  125.         activate_option $Current(widget)
  126.     } else {
  127.         set _Message "No widget is selected"
  128.         bell
  129.     }
  130. }
  131.  
  132. # set the proper menu optiond to active/inactive
  133.  
  134. proc editmenu_active {} {
  135.     global Current
  136.  
  137.     # options that need a selected widget
  138.  
  139.     set state [expr {$Current(widget) == "" ? "disabled" : "normal"}]
  140.     foreach i {{Widget options ...} {Generic options ...} Cut Copy} {
  141.         [menubar_getmenuname .menu $i] entryconfigure $i -state $state
  142.     }
  143.  
  144.     set state [expr {"$Current(widget)$Current(row)$Current(column)" == "" ? "disabled" : "normal"}]
  145.     [menubar_getmenuname .menu Delete] entryconfigure Delete -state $state
  146.  
  147.     set state [expr {![from_clipboard 1]? "disabled" : "normal"}]
  148.     [menubar_getmenuname .menu Paste] entryconfigure Paste -state $state
  149. }
  150.  
  151. proc commandmenu_active {} {
  152.     global Current Widgets
  153.     
  154.     if {[catch {send $Current(test_app) pid}]} {set state disabled} {set state normal}
  155.     [menubar_getmenuname .menu "Kill test"] entryconfigure "Kill test" -state $state
  156.  
  157.     if {[array size Widgets] == 0} {set state disabled } { set state normal}
  158.     [menubar_getmenuname .menu "Build & Test"] entryconfigure "Build & Test" -state $state
  159.     
  160.     if {[llength [array names Widgets scrollbar#*]] == 0} {set state disabled } { set state normal}
  161.     [menubar_getmenuname .menu "Attach scrollbars"] entryconfigure "Attach scrollbars" -state $state
  162.     
  163.     if {$Current(repeat) == ""} {set state disabled } { set state normal}
  164.     [menubar_getmenuname .menu "Re-apply toolbar"] entryconfigure "Re-apply toolbar" -state $state
  165. }
  166.  
  167. # set up the html help
  168.  
  169. # add a "box" tag to put a box around the text
  170. array set HMtag_map {box {Tbox box}}
  171.  
  172. proc html_help {{file help.html}} {
  173.     global _Message Help_history
  174.     set Help_history ""
  175.     set _Message "Loading help..."
  176.     update idletasks
  177.     catch {destroy .help}
  178.     help_ui [toplevel .help]
  179.     update
  180.     HMinit_win .help.text
  181.     # HMset_indent $win 2.2
  182.     # set <dt> text in magenta
  183.     .help.text tag configure hi -foreground magenta
  184.     .help.text tag configure box -borderwidth 3 -relief ridge
  185.     HMlink_callback .help.text $file
  186.     set _Message ""
  187. }
  188.