home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / bwidget1.3.0 / mainframe.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  19.5 KB  |  589 lines
  1. # ------------------------------------------------------------------------------
  2. #  mainframe.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: mainframe.tcl,v 1.9 2001/09/24 19:18:52 jenglish Exp $
  5. # ------------------------------------------------------------------------------
  6. #  Index of commands:
  7. #     - MainFrame::create
  8. #     - MainFrame::configure
  9. #     - MainFrame::cget
  10. #     - MainFrame::getframe
  11. #     - MainFrame::addtoolbar
  12. #     - MainFrame::gettoolbar
  13. #     - MainFrame::addindicator
  14. #     - MainFrame::getindicator
  15. #     - MainFrame::getmenu
  16. #     - MainFrame::menuonly
  17. #     - MainFrame::showtoolbar
  18. #     - MainFrame::showstatusbar
  19. #     - MainFrame::_create_menubar
  20. #     - MainFrame::_create_entries
  21. #     - MainFrame::_parse_name
  22. #     - MainFrame::_parse_accelerator
  23. # ------------------------------------------------------------------------------
  24.  
  25. namespace eval MainFrame {
  26.     ProgressBar::use
  27.  
  28.     Widget::bwinclude MainFrame ProgressBar .status.prg \
  29.         remove {
  30.             -fg -bg -bd -troughcolor -background -borderwidth
  31.             -relief -orient -width -height
  32.         } \
  33.         rename {
  34.             -maximum    -progressmax
  35.             -variable   -progressvar
  36.             -type       -progresstype
  37.             -foreground -progressfg
  38.         }
  39.  
  40.     Widget::declare MainFrame {
  41.         {-width        TkResource 0      0 frame}
  42.         {-height       TkResource 0      0 frame}
  43.         {-background   TkResource ""     0 frame}
  44.         {-textvariable String     ""     0}
  45.         {-menu         String     {}     1}
  46.         {-separator    Enum       both   1 {none top bottom both}}
  47.         {-bg           Synonym    -background}
  48.     }
  49.  
  50.     Widget::addmap MainFrame "" .frame  {-width {} -height {} -background {}}
  51.     Widget::addmap MainFrame "" .topf   {-background {}}
  52.     Widget::addmap MainFrame "" .botf   {-background {}}
  53.     Widget::addmap MainFrame "" .status {-background {}}
  54.     Widget::addmap MainFrame "" .status.label {-background {}}
  55.     Widget::addmap MainFrame "" .status.indf  {-background {}}
  56.     Widget::addmap MainFrame "" .status.prgf  {-background {}}
  57.     Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor}
  58.  
  59.     proc ::MainFrame { path args } { return [eval MainFrame::create $path $args] }
  60.     proc use {} {}
  61.  
  62.     variable _widget
  63. }
  64.  
  65.  
  66. # ------------------------------------------------------------------------------
  67. #  Command MainFrame::create
  68. # ------------------------------------------------------------------------------
  69. proc MainFrame::create { path args } {
  70.     global   tcl_platform
  71.     variable _widget
  72.  
  73.     set path [frame $path -takefocus 0 -highlightthickness 0]
  74.     set top  [winfo parent $path]
  75.     if { [string compare [winfo toplevel $path] $top] } {
  76.         destroy $path
  77.         return -code error "parent must be a toplevel"
  78.     }
  79.     Widget::init MainFrame $path $args
  80.  
  81.     if { $tcl_platform(platform) == "unix" } {
  82.         set relief raised
  83.         set bd     1
  84.     } else {
  85.         set relief flat
  86.         set bd     0
  87.     }
  88.     set topframe  [eval frame $path.topf -relief flat -borderwidth 0 \
  89.         [Widget::subcget $path .topf]]
  90.     set userframe [eval frame $path.frame [Widget::subcget $path .frame] \
  91.                        -relief $relief -borderwidth $bd]
  92.     set botframe  [eval frame $path.botf -relief $relief -borderwidth $bd \
  93.         [Widget::subcget $path .botf]]
  94.  
  95.     pack $topframe -fill x
  96.     grid columnconfigure $topframe 0 -weight 1
  97.  
  98.     set bg [Widget::cget $path -background]
  99.     $path configure -background $bg
  100.     if { $tcl_platform(platform) != "unix" } {
  101.         set sepopt [Widget::getoption $path -separator]
  102.         if { $sepopt == "both" || $sepopt == "top" } {
  103.             set sep [Separator::create $path.sep -orient horizontal -background $bg]
  104.             pack $sep -fill x
  105.         }
  106.         if { $sepopt == "both" || $sepopt == "bottom" } {
  107.             set sep [Separator::create $botframe.sep -orient horizontal -background $bg]
  108.             pack $sep -fill x
  109.         }
  110.     }
  111.  
  112.     # --- status bar -------------------------------------------------------------------------
  113.     set status   [frame $path.status -relief flat -borderwidth 0 \
  114.                       -takefocus 0 -highlightthickness 0 -background $bg]
  115.     set label    [label $status.label -textvariable [Widget::getoption $path -textvariable] \
  116.                       -takefocus 0 -highlightthickness 0 -background $bg]
  117.     set indframe [frame $status.indf -relief flat -borderwidth 0 \
  118.                       -takefocus 0 -highlightthickness 0 -background $bg]
  119.     set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
  120.                       -takefocus 0 -highlightthickness 0 -background $bg]
  121.  
  122.     place $label    -anchor w -x 0 -rely 0.5
  123.     place $indframe -anchor ne -relx 1 -y 0 -relheight 1
  124.     pack  $prgframe -in $indframe -side left -padx 2
  125.     $status configure -height [winfo reqheight $label]
  126.  
  127.     set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
  128.                       -width       50 \
  129.                       -height      [expr {[winfo reqheight $label]-2}] \
  130.                       -borderwidth 1 \
  131.                       -relief      sunken]
  132.     pack $status    -in $botframe -fill x -pady 2
  133.     pack $botframe  -side bottom -fill x
  134.     pack $userframe -fill both -expand yes
  135.  
  136.     set _widget($path,top)      $top
  137.     set _widget($path,ntoolbar) 0
  138.     set _widget($path,nindic)   0
  139.  
  140.     set menu [Widget::getoption $path -menu]
  141.     if { [llength $menu] } {
  142.         _create_menubar $path $menu
  143.     }
  144.  
  145.     bind $path <Destroy> {MainFrame::_destroy %W}
  146.  
  147.     rename $path ::$path:cmd
  148.     proc ::$path { cmd args } "return \[eval MainFrame::\$cmd $path \$args\]"
  149.  
  150.     return $path
  151. }
  152.  
  153.  
  154. # ------------------------------------------------------------------------------
  155. #  Command MainFrame::configure
  156. # ------------------------------------------------------------------------------
  157. proc MainFrame::configure { path args } {
  158.     variable _widget
  159.  
  160.     set res [Widget::configure $path $args]
  161.  
  162.     if { [Widget::hasChanged $path -textvariable newv] } {
  163.         uplevel \#0 $path.status.label configure -textvariable [list $newv]
  164.     }
  165.  
  166.     if { [Widget::hasChanged $path -background bg] } {
  167.         set listmenu [$_widget($path,top) cget -menu]
  168.         while { [llength $listmenu] } {
  169.             set newlist {}
  170.             foreach menu $listmenu {
  171.                 $menu configure -background $bg
  172.                 set newlist [concat $newlist [winfo children $menu]]
  173.             }
  174.             set listmenu $newlist
  175.         }
  176.         foreach sep {.sep .botf.sep} {
  177.             if { [winfo exists $path.$sep] } {
  178.                 Separator::configure $path.$sep -background $bg
  179.             }
  180.         }
  181.         foreach w [winfo children $path.topf] {
  182.             $w configure -background $bg
  183.         }
  184.     }
  185.     return $res
  186. }
  187.  
  188.  
  189. # ------------------------------------------------------------------------------
  190. #  Command MainFrame::cget
  191. # ------------------------------------------------------------------------------
  192. proc MainFrame::cget { path option } {
  193.     return [Widget::cget $path $option]
  194. }
  195.  
  196.  
  197. # ------------------------------------------------------------------------------
  198. #  Command MainFrame::getframe
  199. # ------------------------------------------------------------------------------
  200. proc MainFrame::getframe { path } {
  201.     return $path.frame
  202. }
  203.  
  204.  
  205. # ------------------------------------------------------------------------------
  206. #  Command MainFrame::addtoolbar
  207. # ------------------------------------------------------------------------------
  208. proc MainFrame::addtoolbar { path } {
  209.     global   tcl_platform
  210.     variable _widget
  211.  
  212.     set index     $_widget($path,ntoolbar)
  213.     set toolframe $path.topf.f$index
  214.     set toolbar   $path.topf.tb$index
  215.     set bg        [Widget::getoption $path -background]
  216.     if { $tcl_platform(platform) == "unix" } {
  217.         frame $toolframe -relief raised -borderwidth 1 \
  218.             -takefocus 0 -highlightthickness 0 -background $bg
  219.     } else {
  220.         frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \
  221.             -highlightthickness 0 -background $bg
  222.         set sep [Separator::create $toolframe.sep -orient horizontal -background $bg]
  223.         pack $sep -fill x
  224.     }
  225.     set toolbar [frame $toolbar -relief flat -borderwidth 2 \
  226.                      -takefocus 0 -highlightthickness 0 -background $bg]
  227.     pack $toolbar -in $toolframe -anchor w -expand yes -fill x
  228.     incr _widget($path,ntoolbar)
  229.     grid $toolframe -column 0 -row $index -sticky ew
  230.     return $toolbar
  231. }
  232.  
  233.  
  234. # ------------------------------------------------------------------------------
  235. #  Command MainFrame::gettoolbar
  236. # ------------------------------------------------------------------------------
  237. proc MainFrame::gettoolbar { path index } {
  238.     return $path.topf.tb$index
  239. }
  240.  
  241.  
  242. # ------------------------------------------------------------------------------
  243. #  Command MainFrame::addindicator
  244. # ------------------------------------------------------------------------------
  245. proc MainFrame::addindicator { path args } {
  246.     variable _widget
  247.  
  248.     set index $_widget($path,nindic)
  249.     set indic $path.status.indf.f$index
  250.     eval label $indic $args -relief sunken -borderwidth 1 \
  251.         -takefocus 0 -highlightthickness 0
  252.  
  253.     pack $indic -side left -anchor w -padx 2 -fill y -expand 1
  254.  
  255.     incr _widget($path,nindic)
  256.  
  257.     return $indic
  258. }
  259.  
  260.  
  261. # ------------------------------------------------------------------------------
  262. #  Command MainFrame::getindicator
  263. # ------------------------------------------------------------------------------
  264. proc MainFrame::getindicator { path index } {
  265.     return $path.status.indf.f$index
  266. }
  267.  
  268.  
  269. # ------------------------------------------------------------------------------
  270. #  Command MainFrame::getmenu
  271. # ------------------------------------------------------------------------------
  272. proc MainFrame::getmenu { path menuid } {
  273.     variable _widget
  274.  
  275.     if { [info exists _widget($path,menuid,$menuid)] } {
  276.         return $_widget($path,menuid,$menuid)
  277.     }
  278.     return ""
  279. }
  280.  
  281.  
  282. # -----------------------------------------------------------------------------
  283. #  Command MainFrame::setmenustate
  284. # -----------------------------------------------------------------------------
  285. proc MainFrame::setmenustate { path tag state } {
  286.     variable _widget
  287.  
  288.     #    if { [info exists _widget($path,tags,$tag)] } {
  289.     #        foreach {menu entry} $_widget($path,tags,$tag) {
  290.     #            $menu entryconfigure $entry -state $state
  291.     #        }
  292.     #    }
  293.  
  294.     # We need a more sophisticated state system.
  295.     # The original model was this:  each menu item has a list of tags;
  296.     # whenever any one of those tags changed state, the menu item did too.
  297.     # This makes it hard to have items that are enabled only when both tagA and
  298.     # tagB are.  The new model therefore only sets the menustate to enabled
  299.     # when ALL of its tags are enabled.
  300.  
  301.     # First see if this is a real tag
  302.     if { [info exists _widget($path,tagstate,$tag)] } {
  303.     if { [string compare $state "disabled"] } {
  304.         set _widget($path,tagstate,$tag) 1
  305.     } else {
  306.         set _widget($path,tagstate,$tag) 0
  307.     }
  308.     foreach {menu entry} $_widget($path,tags,$tag) {
  309.         set expression "1"
  310.         foreach menutag $_widget($path,menutags,[list $menu $entry]) {
  311.         append expression " && $_widget($path,tagstate,$menutag)"
  312.         }
  313.         if { [expr $expression] } {
  314.         set state normal
  315.         } else {
  316.         set state disabled
  317.         }
  318.         $menu entryconfigure $entry -state $state
  319.     }
  320.     }
  321.     return
  322. }
  323.  
  324.  
  325. # -----------------------------------------------------------------------------
  326. #  Command MainFrame::menuonly
  327. # ----------------------d------------------------------------------------------
  328. proc MainFrame::menuonly { path } {
  329.     variable _widget
  330.  
  331.     catch {pack forget $path.sep}
  332.     catch {pack forget $path.botf.sep}
  333.     catch {pack forget $path.frame}
  334. }
  335.  
  336. # ------------------------------------------------------------------------------
  337. #  Command MainFrame::showtoolbar
  338. # ------------------------------------------------------------------------------
  339. proc MainFrame::showtoolbar { path index bool } {
  340.     variable _widget
  341.  
  342.     set toolframe $path.topf.f$index
  343.     if { [winfo exists $toolframe] } {
  344.         if { !$bool && [llength [grid info $toolframe]] } {
  345.             grid forget $toolframe
  346.             $path.topf configure -height 1
  347.         } elseif { $bool && ![llength [grid info $toolframe]] } {
  348.             grid $toolframe -column 0 -row $index -sticky ew
  349.         }
  350.     }
  351. }
  352.  
  353.  
  354. # ------------------------------------------------------------------------------
  355. #  Command MainFrame::showstatusbar
  356. # ------------------------------------------------------------------------------
  357. proc MainFrame::showstatusbar { path name } {
  358.     set status $path.status
  359.     if { ![string compare $name "none"] } {
  360.         pack forget $status
  361.     } else {
  362.         pack $status -fill x
  363.         switch -- $name {
  364.             status {
  365.                 catch {pack forget $status.prg}
  366.             }
  367.             progression {
  368.                 pack $status.prg -in $status.prgf
  369.             }
  370.         }
  371.     }
  372. }
  373.  
  374.  
  375. # ------------------------------------------------------------------------------
  376. #  Command MainFrame::_destroy
  377. # ------------------------------------------------------------------------------
  378. proc MainFrame::_destroy { path } {
  379.     variable _widget
  380.  
  381.     Widget::destroy $path
  382.     catch {destroy [$_widget($path,top) cget -menu]}
  383.     $_widget($path,top) configure -menu {}
  384.  
  385.     # Unset all of the state vars associated with this main frame.
  386.     foreach index [array names _widget $path,*] {
  387.     unset _widget($index)
  388.     }
  389.     rename $path {}
  390. }
  391.  
  392.  
  393. # ------------------------------------------------------------------------------
  394. #  Command MainFrame::_create_menubar
  395. # ------------------------------------------------------------------------------
  396. proc MainFrame::_create_menubar { path descmenu } {
  397.     variable _widget
  398.     global    tcl_platform
  399.  
  400.     set bg      [Widget::getoption $path -background]
  401.     set top     $_widget($path,top)
  402.     if { $tcl_platform(platform) == "unix" } {
  403.         set menubar [menu $top.menubar -tearoff 0 -background $bg -borderwidth 1]
  404.     } else {
  405.         set menubar [menu $top.menubar -tearoff 0 -background $bg]
  406.     }
  407.     $top configure -menu $menubar
  408.  
  409.     set count 0
  410.     foreach {name tags menuid tearoff entries} $descmenu {
  411.         set opt  [_parse_name $name]
  412.         if { [string length $menuid] && ![info exists _widget($path,menuid,$menuid)] } {
  413.             # menu has identifier
  414.         # we use it for its pathname, to enable special menu entries
  415.         # (help, system, ...)
  416.         set menu $menubar.$menuid
  417.         } else {
  418.         set menu $menubar.menu$count
  419.     }
  420.         eval $menubar add cascad $opt -menu $menu
  421.         menu $menu -tearoff $tearoff -background $bg
  422.         foreach tag $tags {
  423.             lappend _widget($path,tags,$tag) $menubar $count
  424.         # ericm@scriptics:  Add a tagstate tracker
  425.         if { ![info exists _widget($path,tagstate,$tag)] } {
  426.         set _widget($path,tagstate,$tag) 0
  427.         }
  428.         }
  429.     # ericm@scriptics.com:  Add mapping from menu items to tags
  430.     set _widget($path,menutags,[list $menubar $count]) $tags
  431.         
  432.         if { [string length $menuid] } {
  433.             # menu has identifier
  434.             set _widget($path,menuid,$menuid) $menu
  435.         }
  436.         _create_entries $path $menu $bg $entries
  437.         incr count
  438.     }
  439. }
  440.  
  441.  
  442. # ------------------------------------------------------------------------------
  443. #  Command MainFrame::_create_entries
  444. # ------------------------------------------------------------------------------
  445. proc MainFrame::_create_entries { path menu bg entries } {
  446.     variable _widget
  447.  
  448.     set count      [$menu cget -tearoff]
  449.     set registered 0
  450.     foreach entry $entries {
  451.         set len  [llength $entry]
  452.         set type [lindex $entry 0]
  453.  
  454.         if { ![string compare $type "separator"] } {
  455.             $menu add separator
  456.             incr count
  457.             continue
  458.         }
  459.  
  460.         # entry name and tags
  461.         set opt  [_parse_name [lindex $entry 1]]
  462.         set tags [lindex $entry 2]
  463.         foreach tag $tags {
  464.             lappend _widget($path,tags,$tag) $menu $count
  465.         # ericm@scriptics:  Add a tagstate tracker
  466.         if { ![info exists _widget($path,tagstate,$tag)] } {
  467.         set _widget($path,tagstate,$tag) 0
  468.         }
  469.         }
  470.     # ericm@scriptics.com:  Add mapping from menu items to tags
  471.     set _widget($path,menutags,[list $menu $count]) $tags
  472.  
  473.         if { ![string compare $type "cascad"] } {
  474.             set menuid  [lindex $entry 3]
  475.             set tearoff [lindex $entry 4]
  476.             set submenu $menu.menu$count
  477.             eval $menu add cascad $opt -menu $submenu
  478.             menu $submenu -tearoff $tearoff -background $bg
  479.             if { [string length $menuid] } {
  480.                 # menu has identifier
  481.                 set _widget($path,menuid,$menuid) $submenu
  482.             }
  483.             _create_entries $path $submenu $bg [lindex $entry 5]
  484.             incr count
  485.             continue
  486.         }
  487.  
  488.         # entry help description
  489.         set desc [lindex $entry 3]
  490.         if { [string length $desc] } {
  491.             if { !$registered } {
  492.                 DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
  493.                 set registered 1
  494.             }
  495.             DynamicHelp::register $menu menuentry $count $desc
  496.         }
  497.  
  498.         # entry accelerator
  499.         set accel [_parse_accelerator [lindex $entry 4]]
  500.         if { [llength $accel] } {
  501.             lappend opt -accelerator [lindex $accel 0]
  502.             bind $_widget($path,top) [lindex $accel 1] "$menu invoke $count"
  503.         }
  504.  
  505.         # user options
  506.         set useropt [lrange $entry 5 end]
  507.         if { ![string compare $type "command"] || 
  508.              ![string compare $type "radiobutton"] ||
  509.              ![string compare $type "checkbutton"] } {
  510.             eval $menu add $type $opt $useropt
  511.         } else {
  512.             return -code error "invalid menu type \"$type\""
  513.         }
  514.         incr count
  515.     }
  516. }
  517.  
  518.  
  519. # ------------------------------------------------------------------------------
  520. #  Command MainFrame::_parse_name
  521. # ------------------------------------------------------------------------------
  522. proc MainFrame::_parse_name { menuname } {
  523.     set idx [string first "&" $menuname]
  524.     if { $idx == -1 } {
  525.         return [list -label $menuname]
  526.     } else {
  527.         set beg [string range $menuname 0 [expr {$idx-1}]]
  528.         set end [string range $menuname [expr {$idx+1}] end]
  529.         append beg $end
  530.         return [list -label $beg -underline $idx]
  531.     }
  532. }
  533.  
  534.  
  535. # MainFrame::_parse_accelerator --
  536. #
  537. #    Given a key combo description, construct an appropriate human readable
  538. #    string (for display on as a menu accelerator) and the corresponding
  539. #    bind event.
  540. #
  541. # Arguments:
  542. #    desc    a list with the following format:
  543. #            ?sequence? key
  544. #        sequence may be None, Ctrl, Alt, or CtrlAlt
  545. #        key may be any key
  546. #
  547. # Results:
  548. #    {accel event}    a list containing the accelerator string and the event
  549.  
  550. proc MainFrame::_parse_accelerator { desc } {
  551.     if { [llength $desc] == 1 } {
  552.     set seq None
  553.     set key [string tolower [lindex $desc 0]]
  554.     } elseif { [llength $desc] == 2 } {
  555.         set seq [lindex $desc 0]
  556.         set key [string tolower [lindex $desc 1]]
  557.     # If the key is an F key (ie, F1, F2, etc), it has to be capitalized
  558.     if {[regexp {f[1]?[0-9]*} $key]} {
  559.         set key [string toupper $key]
  560.     }
  561.     } else {
  562.     return {}
  563.     }
  564.     switch -- $seq {
  565.     None {
  566.         set accel "[string toupper $key]"
  567.         set event "<Key-$key>"
  568.     }
  569.     Ctrl {
  570.         set accel "Ctrl+[string toupper $key]"
  571.         set event "<Control-Key-$key>"
  572.     }
  573.     Alt {
  574.         set accel "Alt+[string toupper $key]"
  575.         set event "<Alt-Key-$key>"
  576.     }
  577.     CtrlAlt {
  578.         set accel "Ctrl+Alt+[string toupper $key]"
  579.         set event "<Control-Alt-Key-$key>"
  580.     }
  581.     default {
  582.         return -code error "invalid accelerator code $seq"
  583.     }
  584.     }
  585.     return [list $accel $event]
  586. }
  587.  
  588.  
  589.