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 / button.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  11.0 KB  |  325 lines
  1. # ------------------------------------------------------------------------------
  2. #  button.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. # ------------------------------------------------------------------------------
  5. #  Index of commands:
  6. #   Public commands
  7. #     - Button::create
  8. #     - Button::configure
  9. #     - Button::cget
  10. #     - Button::invoke
  11. #   Private commands (event bindings)
  12. #     - Button::_destroy
  13. #     - Button::_enter
  14. #     - Button::_leave
  15. #     - Button::_press
  16. #     - Button::_release
  17. #     - Button::_repeat
  18. # ------------------------------------------------------------------------------
  19.  
  20. namespace eval Button {
  21.     Widget::tkinclude Button button :cmd \
  22.         remove {-command -relief -text -textvariable -underline -state}
  23.  
  24.     Widget::declare Button {
  25.         {-name            String "" 0}
  26.         {-text            String "" 0}
  27.         {-textvariable    String "" 0}
  28.         {-underline       Int    -1 0 "%d >= -1"}
  29.         {-armcommand      String "" 0}
  30.         {-disarmcommand   String "" 0}
  31.         {-command         String "" 0}
  32.         {-state           TkResource "" 0 button}
  33.         {-repeatdelay     Int    0  0 "%d >= 0"}
  34.         {-repeatinterval  Int    0  0 "%d >= 0"}
  35.         {-relief          Enum   raised  0 {raised sunken flat ridge solid groove link}}
  36.     }
  37.  
  38.     DynamicHelp::include Button balloon
  39.  
  40.     Widget::syncoptions Button "" :cmd {-text {} -underline {}}
  41.  
  42.     variable _current ""
  43.     variable _pressed ""
  44.  
  45.     bind BwButton <Enter>           {Button::_enter %W}
  46.     bind BwButton <Leave>           {Button::_leave %W}
  47.     bind BwButton <ButtonPress-1>   {Button::_press %W}
  48.     bind BwButton <ButtonRelease-1> {Button::_release %W}
  49.     bind BwButton <Key-space>       {Button::invoke %W; break}
  50.     bind BwButton <Return>          {Button::invoke %W; break}
  51.     bind BwButton <Destroy>         {Widget::destroy %W; rename %W {}}
  52.  
  53.     proc ::Button { path args } { return [eval Button::create $path $args] }
  54.     proc use {} {}
  55. }
  56.  
  57.  
  58. # ------------------------------------------------------------------------------
  59. #  Command Button::create
  60. # ------------------------------------------------------------------------------
  61. proc Button::create { path args } {
  62.     array set maps [list Button {} :cmd {}]
  63.     array set maps [Widget::parseArgs Button $args]
  64.     eval [concat [list button $path] $maps(:cmd)]
  65.     Widget::initFromODB Button $path $maps(Button)
  66.  
  67.     # Do some extra configuration on the button
  68.     set relief [Widget::getMegawidgetOption $path -relief]
  69.     if { ![string compare $relief "link"] } {
  70.         set relief "flat"
  71.     }
  72.     set var [Widget::getMegawidgetOption $path -textvariable]
  73.     set st [Widget::getMegawidgetOption $path -state]
  74.     if {  ![string length $var] } {
  75.         set desc [BWidget::getname [Widget::getMegawidgetOption $path -name]]
  76.         if { [llength $desc] } {
  77.             set text  [lindex $desc 0]
  78.             set under [lindex $desc 1]
  79.             Widget::configure $path [list -text $text]
  80.             Widget::configure $path [list -underline $under]
  81.         } else {
  82.             set text  [Widget::getMegawidgetOption $path -text]
  83.             set under [Widget::getMegawidgetOption $path -underline]
  84.         }
  85.     } else {
  86.         set under -1
  87.         set text  ""
  88.         Widget::configure $path [list -underline $under]
  89.     }
  90.  
  91.     $path configure -relief $relief -text $text -underline $under \
  92.         -textvariable $var -state $st
  93.     bindtags $path [list $path BwButton [winfo toplevel $path] all]
  94.  
  95.     set accel1 [string tolower [string index $text $under]]
  96.     set accel2 [string toupper $accel1]
  97.     if { $accel1 != "" } {
  98.         bind [winfo toplevel $path] <Alt-$accel1> "Button::invoke $path"
  99.         bind [winfo toplevel $path] <Alt-$accel2> "Button::invoke $path"    
  100.     }
  101.  
  102.     DynamicHelp::sethelp $path $path 1
  103.  
  104.     rename $path ::$path:cmd
  105.     proc ::$path { cmd args } "return \[eval Button::\$cmd $path \$args\]"
  106.  
  107.     return $path
  108. }
  109.  
  110.  
  111. # ------------------------------------------------------------------------------
  112. #  Command Button::configure
  113. # ------------------------------------------------------------------------------
  114. proc Button::configure { path args } {
  115.     set oldunder [$path:cmd cget -underline]
  116.     if { $oldunder != -1 } {
  117.         set oldaccel1 [string tolower [string index [$path:cmd cget -text] $oldunder]]
  118.         set oldaccel2 [string toupper $oldaccel1]
  119.     } else {
  120.         set oldaccel1 ""
  121.         set oldaccel2 ""
  122.     }
  123.     set res [Widget::configure $path $args]
  124.  
  125.     # Extract all the modified bits we're interested in
  126.     foreach {cr cs cv cn ct cu} [Widget::hasChangedX $path \
  127.         -relief -state -textvariable -name -text -underline] break
  128.     if { $cr || $cs } {
  129.     set relief [Widget::cget $path -relief]
  130.     set state  [Widget::cget $path -state]
  131.         if { ![string compare $relief "link"] } {
  132.             if { ![string compare $state "active"] } {
  133.                 set relief "raised"
  134.             } else {
  135.                 set relief "flat"
  136.             }
  137.         }
  138.         $path:cmd configure -relief $relief -state $state
  139.     }
  140.  
  141.     if { $cv || $cn || $ct || $cu } {
  142.     set var        [Widget::cget $path -textvariable]
  143.     set text    [Widget::cget $path -text]
  144.     set under    [Widget::cget $path -underline]
  145.         if {  ![string length $var] } {
  146.             set desc [BWidget::getname [Widget::cget $path -name]]
  147.             if { [llength $desc] } {
  148.                 set text  [lindex $desc 0]
  149.                 set under [lindex $desc 1]
  150.             }
  151.         } else {
  152.             set under -1
  153.             set text  ""
  154.         }
  155.         set top [winfo toplevel $path]
  156.         if { $oldaccel1 != "" } {
  157.             bind $top <Alt-$oldaccel1> {}
  158.             bind $top <Alt-$oldaccel2> {}
  159.         }
  160.         set accel1 [string tolower [string index $text $under]]
  161.         set accel2 [string toupper $accel1]
  162.         if { $accel1 != "" } {
  163.             bind $top <Alt-$accel1> "Button::invoke $path"
  164.             bind $top <Alt-$accel2> "Button::invoke $path"
  165.         }
  166.         $path:cmd configure -text $text -underline $under -textvariable $var
  167.     }
  168.     DynamicHelp::sethelp $path $path
  169.  
  170.     set res
  171. }
  172.  
  173.  
  174. # ------------------------------------------------------------------------------
  175. #  Command Button::cget
  176. # ------------------------------------------------------------------------------
  177. proc Button::cget { path option } {
  178.     Widget::cget $path $option
  179. }
  180.  
  181.  
  182. # ------------------------------------------------------------------------------
  183. #  Command Button::invoke
  184. # ------------------------------------------------------------------------------
  185. proc Button::invoke { path } {
  186.     if { [string compare [$path:cmd cget -state] "disabled"] } {
  187.     $path:cmd configure -state active -relief sunken
  188.     update idletasks
  189.     set cmd [Widget::getMegawidgetOption $path -armcommand]
  190.         if { $cmd != "" } {
  191.             uplevel \#0 $cmd
  192.         }
  193.     after 100
  194.         set relief [Widget::getMegawidgetOption $path -relief]
  195.         if { ![string compare $relief "link"] } {
  196.             set relief flat
  197.         }
  198.     $path:cmd configure \
  199.             -state  [Widget::getMegawidgetOption $path -state] \
  200.             -relief $relief
  201.     set cmd [Widget::getMegawidgetOption $path -disarmcommand]
  202.         if { $cmd != "" } {
  203.             uplevel \#0 $cmd
  204.         }
  205.     set cmd [Widget::getMegawidgetOption $path -command]
  206.         if { $cmd != "" } {
  207.             uplevel \#0 $cmd
  208.         }
  209.     }
  210. }
  211.  
  212.  
  213. # ------------------------------------------------------------------------------
  214. #  Command Button::_enter
  215. # ------------------------------------------------------------------------------
  216. proc Button::_enter { path } {
  217.     variable _current
  218.     variable _pressed
  219.  
  220.     set _current $path
  221.     if { [string compare [$path:cmd cget -state] "disabled"] } {
  222.         $path:cmd configure -state active
  223.         if { $_pressed == $path } {
  224.             $path:cmd configure -relief sunken
  225.         } elseif { ![string compare [Widget::cget $path -relief] "link"] } {
  226.             $path:cmd configure -relief raised
  227.         }
  228.     }
  229. }
  230.  
  231.  
  232. # ------------------------------------------------------------------------------
  233. #  Command Button::_leave
  234. # ------------------------------------------------------------------------------
  235. proc Button::_leave { path } {
  236.     variable _current
  237.     variable _pressed
  238.  
  239.     set _current ""
  240.     if { [string compare [$path:cmd cget -state] "disabled"] } {
  241.         $path:cmd configure -state [Widget::cget $path -state]
  242.         set relief [Widget::cget $path -relief]
  243.         if { $_pressed == $path } {
  244.             if { ![string compare $relief "link"] } {
  245.                 set relief raised
  246.             }
  247.             $path:cmd configure -relief $relief
  248.         } elseif { ![string compare $relief "link"] } {
  249.             $path:cmd configure -relief flat
  250.         }
  251.     }
  252. }
  253.  
  254.  
  255. # ------------------------------------------------------------------------------
  256. #  Command Button::_press
  257. # ------------------------------------------------------------------------------
  258. proc Button::_press { path } {
  259.     variable _pressed
  260.  
  261.     if { [string compare [$path:cmd cget -state] "disabled"] } {
  262.         set _pressed $path
  263.     $path:cmd configure -relief sunken
  264.     set cmd [Widget::getMegawidgetOption $path -armcommand]
  265.         if { $cmd != "" } {
  266.             uplevel \#0 $cmd
  267.         set repeatdelay [Widget::getMegawidgetOption $path -repeatdelay]
  268.         set repeatint [Widget::getMegawidgetOption $path -repeatinterval]
  269.             if { $repeatdelay > 0 } {
  270.                 after $repeatdelay "Button::_repeat $path"
  271.             } elseif { $repeatint > 0 } {
  272.                 after $repeatint "Button::_repeat $path"
  273.         }
  274.         }
  275.     }
  276. }
  277.  
  278.  
  279. # ------------------------------------------------------------------------------
  280. #  Command Button::_release
  281. # ------------------------------------------------------------------------------
  282. proc Button::_release { path } {
  283.     variable _current
  284.     variable _pressed
  285.  
  286.     if { $_pressed == $path } {
  287.         set _pressed ""
  288.         set relief [Widget::getMegawidgetOption $path -relief]
  289.         if { ![string compare $relief "link"] } {
  290.             set relief raised
  291.         }
  292.         $path:cmd configure -relief $relief
  293.     set cmd [Widget::getMegawidgetOption $path -disarmcommand]
  294.         if { $cmd != "" } {
  295.             uplevel \#0 $cmd
  296.         }
  297.         if { $_current == $path &&
  298.              [string compare [$path:cmd cget -state] "disabled"] && \
  299.          [set cmd [Widget::getMegawidgetOption $path -command]] != "" } {
  300.             uplevel \#0 $cmd
  301.         }
  302.     }
  303. }
  304.  
  305.  
  306. # ------------------------------------------------------------------------------
  307. #  Command Button::_repeat
  308. # ------------------------------------------------------------------------------
  309. proc Button::_repeat { path } {
  310.     variable _current
  311.     variable _pressed
  312.  
  313.     if { $_current == $path && $_pressed == $path &&
  314.          [string compare [$path:cmd cget -state] "disabled"] &&
  315.          [set cmd [Widget::getMegawidgetOption $path -armcommand]] != "" } {
  316.         uplevel \#0 $cmd
  317.     }
  318.     if { $_pressed == $path &&
  319.          ([set delay [Widget::getMegawidgetOption $path -repeatinterval]] >0 ||
  320.           [set delay [Widget::getMegawidgetOption $path -repeatdelay]] > 0) } {
  321.         after $delay "Button::_repeat $path"
  322.     }
  323. }
  324.  
  325.