home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / mainframe.tcl < prev    next >
Text File  |  2000-11-02  |  18KB  |  500 lines
  1. # ------------------------------------------------------------------------------
  2. #  mainframe.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: mainframe.tcl,v 1.1.1.1 1996/02/22 06:05:56 daniel 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::showtoolbar
  17. #     - MainFrame::showstatusbar
  18. #     - MainFrame::_create_menubar
  19. #     - MainFrame::_create_entries
  20. #     - MainFrame::_parse_name
  21. #     - MainFrame::_parse_accelerator
  22. # ------------------------------------------------------------------------------
  23.  
  24. namespace eval MainFrame {
  25.     ProgressBar::use
  26.  
  27.     Widget::bwinclude MainFrame ProgressBar .status.prg \
  28.         remove {
  29.             -fg -bg -bd -troughcolor -background -borderwidth
  30.             -relief -orient -width -height
  31.         } \
  32.         rename {
  33.             -maximum    -progressmax
  34.             -variable   -progressvar
  35.             -type       -progresstype
  36.             -foreground -progressfg
  37.         }
  38.  
  39.     Widget::declare MainFrame {
  40.         {-width        TkResource 0      0 frame}
  41.         {-height       TkResource 0      0 frame}
  42.         {-background   TkResource ""     0 frame}
  43.         {-textvariable String     ""     0}
  44.         {-menu         String     {}     1}
  45.         {-separator    Enum       both   1 {none top bottom both}}
  46.         {-bg           Synonym    -background}
  47.     }
  48.  
  49.     Widget::addmap MainFrame "" .frame  {-width {} -height {} -background {}}
  50.     Widget::addmap MainFrame "" .topf   {-background {}}
  51.     Widget::addmap MainFrame "" .botf   {-background {}}
  52.     Widget::addmap MainFrame "" .status {-background {}}
  53.     Widget::addmap MainFrame "" .status.label {-background {}}
  54.     Widget::addmap MainFrame "" .status.indf  {-background {}}
  55.     Widget::addmap MainFrame "" .status.prgf  {-background {}}
  56.     Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor}
  57.  
  58.     proc ::MainFrame { path args } { return [eval MainFrame::create $path $args] }
  59.     proc use {} {}
  60.  
  61.     variable _widget
  62. }
  63.  
  64.  
  65. # ------------------------------------------------------------------------------
  66. #  Command MainFrame::create
  67. # ------------------------------------------------------------------------------
  68. proc MainFrame::create { path args } {
  69.     global   tcl_platform
  70.     variable _widget
  71.  
  72.     set path [frame $path -takefocus 0 -highlightthickness 0]
  73.     set top  [winfo parent $path]
  74.     if { [string compare [winfo toplevel $path] $top] } {
  75.         destroy $path
  76.         return -code error "parent must be a toplevel"
  77.     }
  78.     Widget::init MainFrame $path $args
  79.  
  80.     set bg [Widget::getoption $path -background]
  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.     $path configure -background $bg
  89.     set topframe  [frame $path.topf -relief flat -borderwidth 0 -background $bg]
  90.     set userframe [eval frame $path.frame [Widget::subcget $path .frame] \
  91.                        -relief $relief -borderwidth $bd]
  92.     set botframe  [frame $path.botf -relief $relief -borderwidth $bd -background $bg]
  93.  
  94.     pack $topframe -fill x
  95.     grid columnconfigure $topframe 0 -weight 1
  96.  
  97.     if { $tcl_platform(platform) != "unix" } {
  98.         set sepopt [Widget::getoption $path -separator]
  99.         if { $sepopt == "both" || $sepopt == "top" } {
  100.             set sep [Separator::create $path.sep -orient horizontal -background $bg]
  101.             pack $sep -fill x
  102.         }
  103.         if { $sepopt == "both" || $sepopt == "bottom" } {
  104.             set sep [Separator::create $botframe.sep -orient horizontal -background $bg]
  105.             pack $sep -fill x
  106.         }
  107.     }
  108.  
  109.     # --- status bar -------------------------------------------------------------------------
  110.     set status   [frame $path.status -relief flat -borderwidth 0 \
  111.                       -takefocus 0 -highlightthickness 0 -background $bg]
  112.     set label    [label $status.label -textvariable [Widget::getoption $path -textvariable] \
  113.                       -takefocus 0 -highlightthickness 0 -background $bg]
  114.     set indframe [frame $status.indf -relief flat -borderwidth 0 \
  115.                       -takefocus 0 -highlightthickness 0 -background $bg]
  116.     set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
  117.                       -takefocus 0 -highlightthickness 0 -background $bg]
  118.  
  119.     place $label    -anchor w -x 0 -rely 0.5
  120.     place $indframe -anchor e -relx 1 -rely 0.5
  121.     pack  $prgframe -in $indframe -side left -padx 2
  122.     $status configure -height [winfo reqheight $label]
  123.  
  124.     set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
  125.                       -width       50 \
  126.                       -height      [expr {[winfo reqheight $label]-2}] \
  127.                       -borderwidth 1 \
  128.                       -relief      sunken]
  129.     pack $status    -in $botframe -fill x -pady 2
  130.     pack $botframe  -side bottom -fill x
  131.     pack $userframe -fill both -expand yes
  132.  
  133.     set _widget($path,top)      $top
  134.     set _widget($path,ntoolbar) 0
  135.     set _widget($path,nindic)   0
  136.  
  137.     set menu [Widget::getoption $path -menu]
  138.     if { [llength $menu] } {
  139.         _create_menubar $path $menu
  140.     }
  141.  
  142.     bind $path <Destroy> {MainFrame::_destroy %W}
  143.  
  144.     rename $path ::$path:cmd
  145.     proc ::$path { cmd args } "return \[eval MainFrame::\$cmd $path \$args\]"
  146.  
  147.     return $path
  148. }
  149.  
  150.  
  151. # ------------------------------------------------------------------------------
  152. #  Command MainFrame::configure
  153. # ------------------------------------------------------------------------------
  154. proc MainFrame::configure { path args } {
  155.     variable _widget
  156.  
  157.     set res [Widget::configure $path $args]
  158.  
  159.     if { [Widget::hasChanged $path -textvariable newv] } {
  160.         uplevel \#0 $path.status.label configure -textvariable $newv
  161.     }
  162.  
  163.     if { [Widget::hasChanged $path -background bg] } {
  164.         set listmenu [$_widget($path,top) cget -menu]
  165.         while { [llength $listmenu] } {
  166.             set newlist {}
  167.             foreach menu $listmenu {
  168.                 $menu configure -background $bg
  169.                 set newlist [concat $newlist [winfo children $menu]]
  170.             }
  171.             set listmenu $newlist
  172.         }
  173.         foreach sep {.sep .botf.sep} {
  174.             if { [winfo exists $path.$sep] } {
  175.                 Separator::configure $path.$sep -background $bg
  176.             }
  177.         }
  178.         foreach w [winfo children $path.topf] {
  179.             $w configure -background $bg
  180.         }
  181.     }
  182.     return $res
  183. }
  184.  
  185.  
  186. # ------------------------------------------------------------------------------
  187. #  Command MainFrame::cget
  188. # ------------------------------------------------------------------------------
  189. proc MainFrame::cget { path option } {
  190.     return [Widget::cget $path $option]
  191. }
  192.  
  193.  
  194. # ------------------------------------------------------------------------------
  195. #  Command MainFrame::getframe
  196. # ------------------------------------------------------------------------------
  197. proc MainFrame::getframe { path } {
  198.     return $path.frame
  199. }
  200.  
  201.  
  202. # ------------------------------------------------------------------------------
  203. #  Command MainFrame::addtoolbar
  204. # ------------------------------------------------------------------------------
  205. proc MainFrame::addtoolbar { path } {
  206.     global   tcl_platform
  207.     variable _widget
  208.  
  209.     set index     $_widget($path,ntoolbar)
  210.     set toolframe $path.topf.f$index
  211.     set toolbar   $path.topf.tb$index
  212.     set bg        [Widget::getoption $path -background]
  213.     if { $tcl_platform(platform) == "unix" } {
  214.         frame $toolframe -relief raised -borderwidth 1 \
  215.             -takefocus 0 -highlightthickness 0 -background $bg
  216.     } else {
  217.         frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \
  218.             -highlightthickness 0 -background $bg
  219.         set sep [Separator::create $toolframe.sep -orient horizontal -background $bg]
  220.         pack $sep -fill x
  221.     }
  222.     set toolbar [frame $toolbar -relief flat -borderwidth 2 \
  223.                      -takefocus 0 -highlightthickness 0 -background $bg]
  224.     pack $toolbar -in $toolframe -anchor w
  225.     incr _widget($path,ntoolbar)
  226.     grid $toolframe -column 0 -row $index -sticky ew
  227.     return $toolbar
  228. }
  229.  
  230.  
  231. # ------------------------------------------------------------------------------
  232. #  Command MainFrame::gettoolbar
  233. # ------------------------------------------------------------------------------
  234. proc MainFrame::gettoolbar { path index } {
  235.     return $path.topf.tb$index
  236. }
  237.  
  238.  
  239. # ------------------------------------------------------------------------------
  240. #  Command MainFrame::addindicator
  241. # ------------------------------------------------------------------------------
  242. proc MainFrame::addindicator { path args } {
  243.     variable _widget
  244.  
  245.     set index $_widget($path,nindic)
  246.     set indic $path.status.indf.f$index
  247.     eval label $indic $args -relief sunken -borderwidth 1 \
  248.         -takefocus 0 -highlightthickness 0
  249.  
  250.     pack $indic -side left -anchor w -padx 2
  251.  
  252.     incr _widget($path,nindic)
  253.  
  254.     return $indic
  255. }
  256.  
  257.  
  258. # ------------------------------------------------------------------------------
  259. #  Command MainFrame::getindicator
  260. # ------------------------------------------------------------------------------
  261. proc MainFrame::getindicator { path index } {
  262.     return $path.status.indf.f$index
  263. }
  264.  
  265.  
  266. # ------------------------------------------------------------------------------
  267. #  Command MainFrame::getmenu
  268. # ------------------------------------------------------------------------------
  269. proc MainFrame::getmenu { path menuid } {
  270.     variable _widget
  271.  
  272.     if { [info exists _widget($path,menuid,$menuid)] } {
  273.         return $_widget($path,menuid,$menuid)
  274.     }
  275.     return ""
  276. }
  277.  
  278.  
  279. # ------------------------------------------------------------------------------
  280. #  Command MainFrame::setmenustate
  281. # ------------------------------------------------------------------------------
  282. proc MainFrame::setmenustate { path tag state } {
  283.     variable _widget
  284.  
  285.     if { [info exists _widget($path,tags,$tag)] } {
  286.         foreach {menu entry} $_widget($path,tags,$tag) {
  287.             $menu entryconfigure $entry -state $state
  288.         }
  289.     }
  290. }
  291.  
  292.  
  293. # ------------------------------------------------------------------------------
  294. #  Command MainFrame::showtoolbar
  295. # ------------------------------------------------------------------------------
  296. proc MainFrame::showtoolbar { path index bool } {
  297.     variable _widget
  298.  
  299.     set toolframe $path.topf.f$index
  300.     if { [winfo exists $toolframe] } {
  301.         if { !$bool && [llength [grid info $toolframe]] } {
  302.             grid forget $toolframe
  303.             $path.topf configure -height 1
  304.         } elseif { $bool && ![llength [grid info $toolframe]] } {
  305.             grid $toolframe -column 0 -row $index -sticky ew
  306.         }
  307.     }
  308. }
  309.  
  310.  
  311. # ------------------------------------------------------------------------------
  312. #  Command MainFrame::showstatusbar
  313. # ------------------------------------------------------------------------------
  314. proc MainFrame::showstatusbar { path name } {
  315.     set status $path.status
  316.     if { ![string compare $name "none"] } {
  317.         pack forget $status
  318.     } else {
  319.         pack $status -fill x
  320.         switch -- $name {
  321.             status {
  322.                 catch {pack forget $status.prg}
  323.             }
  324.             progression {
  325.                 pack $status.prg -in $status.prgf
  326.             }
  327.         }
  328.     }
  329. }
  330.  
  331.  
  332. # ------------------------------------------------------------------------------
  333. #  Command MainFrame::_destroy
  334. # ------------------------------------------------------------------------------
  335. proc MainFrame::_destroy { path } {
  336.     variable _widget
  337.  
  338.     Widget::destroy $path
  339.     catch {destroy [$_widget($path,top) cget -menu]}
  340.     $_widget($path,top) configure -menu {}
  341.     unset _widget($path,top)
  342.     unset _widget($path,ntoolbar)
  343.     unset _widget($path,nindic)
  344.     rename $path {}
  345. }
  346.  
  347.  
  348. # ------------------------------------------------------------------------------
  349. #  Command MainFrame::_create_menubar
  350. # ------------------------------------------------------------------------------
  351. proc MainFrame::_create_menubar { path descmenu } {
  352.     variable _widget
  353.     global    tcl_platform
  354.  
  355.     set bg      [Widget::getoption $path -background]
  356.     set top     $_widget($path,top)
  357.     if { $tcl_platform(platform) == "unix" } {
  358.         set menubar [menu $top.menubar -tearoff 0 -background $bg -borderwidth 1]
  359.     } else {
  360.         set menubar [menu $top.menubar -tearoff 0 -background $bg]
  361.     }
  362.     $top configure -menu $menubar
  363.  
  364.     set count 0
  365.     foreach {name tags menuid tearoff entries} $descmenu {
  366.         set opt  [_parse_name $name]
  367.         set menu $menubar.menu$count
  368.         eval $menubar add cascad $opt -menu $menu
  369.         menu $menu -tearoff $tearoff -background $bg
  370.         foreach tag $tags {
  371.             lappend _widget($path,tags,$tag) $menubar $count
  372.         }
  373.         if { [string length $menuid] } {
  374.             # menu has identifier
  375.             set _widget($path,menuid,$menuid) $menu
  376.         }
  377.         _create_entries $path $menu $bg $entries
  378.         incr count
  379.     }
  380. }
  381.  
  382.  
  383. # ------------------------------------------------------------------------------
  384. #  Command MainFrame::_create_entries
  385. # ------------------------------------------------------------------------------
  386. proc MainFrame::_create_entries { path menu bg entries } {
  387.     variable _widget
  388.  
  389.     set count      [$menu cget -tearoff]
  390.     set registered 0
  391.     foreach entry $entries {
  392.         set len  [llength $entry]
  393.         set type [lindex $entry 0]
  394.  
  395.         if { ![string compare $type "separator"] } {
  396.             $menu add separator
  397.             incr count
  398.             continue
  399.         }
  400.  
  401.         # entry name and tags
  402.         set opt  [_parse_name [lindex $entry 1]]
  403.         set tags [lindex $entry 2]
  404.         foreach tag $tags {
  405.             lappend _widget($path,tags,$tag) $menu $count
  406.         }
  407.  
  408.         if { ![string compare $type "cascad"] } {
  409.             set menuid  [lindex $entry 3]
  410.             set tearoff [lindex $entry 4]
  411.             set submenu $menu.menu$count
  412.             eval $menu add cascad $opt -menu $submenu
  413.             menu $submenu -tearoff $tearoff -background $bg
  414.             if { [string length $menuid] } {
  415.                 # menu has identifier
  416.                 set _widget($path,menuid,$menuid) $submenu
  417.             }
  418.             _create_entries $path $submenu $bg [lindex $entry 5]
  419.             incr count
  420.             continue
  421.         }
  422.  
  423.         # entry help description
  424.         set desc [lindex $entry 3]
  425.         if { [string length $desc] } {
  426.             if { !$registered } {
  427.                 DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
  428.                 set registered 1
  429.             }
  430.             DynamicHelp::register $menu menuentry $count $desc
  431.         }
  432.  
  433.         # entry accelerator
  434.         set accel [_parse_accelerator [lindex $entry 4]]
  435.         if { [llength $accel] } {
  436.             lappend opt -accelerator [lindex $accel 0]
  437.             bind $_widget($path,top) [lindex $accel 1] "$menu invoke $count"
  438.         }
  439.  
  440.         # user options
  441.         set useropt [lrange $entry 5 end]
  442.         if { ![string compare $type "command"] || 
  443.              ![string compare $type "radiobutton"] ||
  444.              ![string compare $type "checkbutton"] } {
  445.             eval $menu add $type $opt $useropt
  446.         } else {
  447.             return -code error "invalid menu type \"$type\""
  448.         }
  449.         incr count
  450.     }
  451. }
  452.  
  453.  
  454. # ------------------------------------------------------------------------------
  455. #  Command MainFrame::_parse_name
  456. # ------------------------------------------------------------------------------
  457. proc MainFrame::_parse_name { menuname } {
  458.     set idx [string first "&" $menuname]
  459.     if { $idx == -1 } {
  460.         return [list -label $menuname]
  461.     } else {
  462.         set beg [string range $menuname 0 [expr $idx-1]]
  463.         set end [string range $menuname [expr $idx+1] end]
  464.         append beg $end
  465.         return [list -label $beg -underline $idx]
  466.     }
  467. }
  468.  
  469.  
  470. # ------------------------------------------------------------------------------
  471. #  Command MainFrame::_parse_accelerator
  472. # ------------------------------------------------------------------------------
  473. proc MainFrame::_parse_accelerator { desc } {
  474.     if { [llength $desc] == 2 } {
  475.         set seq [lindex $desc 0]
  476.         set key [lindex $desc 1]
  477.         switch -- $seq {
  478.             Ctrl {
  479.                 set accel "Ctrl+[string toupper $key]"
  480.                 set event "<Control-Key-[string tolower $key]>"
  481.             }
  482.             Alt {
  483.                 set accel "Atl+[string toupper $key]"
  484.                 set event "<Alt-Key-[string tolower $key]>"
  485.             }
  486.             CtrlAlt {
  487.                 set accel "Ctrl+Alt+[string toupper $key]"
  488.                 set event "<Control-Alt-Key-[string tolower $key]>"
  489.             }
  490.             default {
  491.                 return -code error "invalid accelerator code $seq"
  492.             }
  493.         }
  494.         return [list $accel $event]
  495.     }
  496.     return {}
  497. }
  498.  
  499.  
  500.