lib/gui_script/menubar.tcl

   1 set _MenuData(next) 0
   2
   3 proc menubar_create {menulist {top .}} {
   4   global _MenuData tcl_platform bgColor
   5
   6   if {$top == "." || $top == ""} {
   7     set mw .menubar
   8     set ms .menusep
   9   } else {
  10     set mw $top.menubar
  11     set ms $top.menusep
  12   }
  13
  14   set _MenuData(menu) $mw
  15   set _MenuData(list) ""
  16
  17   if {$tcl_platform(platform) == "windows"} {
  18     menu $mw -tearoff 0 -relief flat -type menubar
  19     foreach j $menulist {
  20       set i [string tolower $j]
  21       lappend _MenuData(list) $i
  22       set m m$_MenuData(next)
  23       incr _MenuData(next)
  24       $mw add cascade -label $j -menu $mw.$m -underline 0
  25       menu $mw.$m -tearoff 0
  26       set _MenuData($i,menu) $mw.$m
  27     }
  28     . configure -menu $mw
  29   } else {
  30     frame $mw -relief flat -bg $bgColor(button)
  31     pack $mw -side top -fill x
  32     foreach j $menulist {
  33       set i [string tolower $j]
  34       lappend _MenuData(list) $i
  35       set m m$_MenuData(next)
  36       incr _MenuData(next)
  37       menubutton $mw.$m -text $j -menu $mw.$m.menu -pady 0 \
  38         -highlightthickness 0 -underline 0
  39       pack $mw.$m -side left -padx 5
  40       menu $mw.$m.menu -tearoff 0
  41       set _MenuData($i,menu) $mw.$m.menu
  42     }
  43   }
  44
  45   frame $ms -bd 1 -height 2 -relief sunken
  46   pack $ms -side top -fill x
  47 }
  48
  49 proc menubar_add {menu {before ""}} {
  50   global tcl_platform _MenuData bgColor
  51
  52   set i [string tolower $menu]
  53   if {[info exists _MenuData($i,menu)]} {
  54     return $_MenuData($i,menu)
  55   }
  56   set where ""
  57   if {$before != ""} {
  58     set before [string tolower $before]
  59     set n [lsearch $_MenuData(list) $before]
  60     if {$n >= 0} {set where $n}
  61   }
  62   set mw $_MenuData(menu)
  63   set m m$_MenuData(next)
  64   incr _MenuData(next)
  65
  66   if {$tcl_platform(platform) == "windows"} {
  67     if {$where == ""} {
  68       $mw add cascade -label $menu -menu $mw.$m -underline 0
  69     } else {
  70       $mw insert $where cascade -label $menu -menu $mw.$m -underline 0
  71     }
  72     set _MenuData($i,menu) $mw.$m
  73   } else {
  74     menubutton $mw.$m -text $menu -menu $mw.$m.menu -pady 0 \
  75       -highlightthickness 0 -underline 0
  76     if {$where == ""} {
  77       pack $mw.$m -side left -padx 5
  78     } else {
  79       pack $mw.$m -side left -padx 5 \
  80         -before [winfo parent $_MenuData($before,menu)]
  81     }
  82     set _MenuData($i,menu) $mw.$m.menu
  83   }
  84
  85   menu $_MenuData($i,menu) -tearoff 0
  86   if {$where == ""} {
  87     lappend _MenuData(list) $i
  88   } else {
  89     set _MenuData(list) [linsert $_MenuData(list) $where $i]
  90   }
  91   return $_MenuData($i,menu)
  92 }
  93
  94 proc menubar_delete {menu} {
  95   global _MenuData tcl_platform
  96
  97   set i [string tolower $menu]
  98   set n [lsearch $_MenuData(list) $i]
  99   if {$n < 0} return
 100   if {$tcl_platform(platform) == "windows"} {
 101     $_MenuData(menu) delete $n $n
 102   } else {
 103     set m [winfo parent $_Menudata($i,menu)]
 104     pack forget $m
 105     destroy $m
 106   }
 107   set _MenuData(list) [lreplace $_MenuData(list) $n $n]
 108 }
 109
 110 proc menubar_get {menu} {
 111   global _MenuData
 112   set i [string tolower $menu]
 113   if {[lsearch $_MenuData(list) $i] >= 0} {
 114     return $_MenuData($i,menu)
 115   }
 116   return ""
 117 }
 118
 119 proc menubar_state {menu state {entry ""}} {
 120   global _MenuData tcl_platform
 121
 122   set i [string tolower $menu]
 123   set n [lsearch $_MenuData(list) $i]
 124   if {$n < 0} return
 125   if {$entry != ""} {
 126     $_MenuData($i,menu) entryconfigure $entry -state $state
 127   } elseif {$tcl_platform(platform) == "windows"} {
 128     $_MenuData(menu) entryconfigure $n -state $state
 129   } else {
 130     [winfo parent $_MenuData($i,menu)] configure -state $state
 131   }
 132 }
 133