"Fossies" - the Fresh Open Source Software Archive

Member "Pansophica-src-1.3/BAF_modules/tcl/src/NVR_BWidgets/button.tcl" (10 Apr 2007, 10181 Bytes) of package /linux/www/old/Pansophica-src-1.3-1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "button.tcl" see the Fossies "Dox" file reference documentation.

    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}
   23 
   24     Widget::declare Button {
   25         {-name            String "" 0}
   26         {-text            String "" 0}
   27         {-textvariable    String "" 0}
   28         {-underline       Int    -1 0 {=-1}}
   29         {-armcommand      String "" 0}
   30         {-disarmcommand   String "" 0}
   31         {-command         String "" 0}
   32         {-repeatdelay     Int    0  0 {=0 ""}}
   33         {-repeatinterval  Int    0  0 {=0 ""}}
   34         {-relief          Enum   raised  0 {raised sunken flat ridge solid groove link}}
   35     }
   36 
   37     DynamicHelp::include Button balloon
   38 
   39     Widget::syncoptions Button "" :cmd {-text {} -underline {}}
   40 
   41     variable _current ""
   42     variable _pressed ""
   43 
   44     bind BwButton <Enter>           {Button::_enter %W}
   45     bind BwButton <Leave>           {Button::_leave %W}
   46     bind BwButton <ButtonPress-1>   {Button::_press %W}
   47     bind BwButton <ButtonRelease-1> {Button::_release %W}
   48     bind BwButton <Key-space>       {Button::invoke %W; break}
   49     bind BwButton <Return>          {Button::invoke %W; break}
   50     bind BwButton <Destroy>         {Widget::destroy %W; rename %W {}}
   51 
   52     proc ::Button { path args } { return [eval Button::create $path $args] }
   53     proc use {} {}
   54 }
   55 
   56 
   57 # ------------------------------------------------------------------------------
   58 #  Command Button::create
   59 # ------------------------------------------------------------------------------
   60 proc Button::create { path args } {
   61     Widget::init Button $path $args
   62 
   63     set relief [Widget::getoption $path -relief]
   64     if { ![string compare $relief "link"] } {
   65         set relief "flat"
   66     }
   67 
   68     set var [Widget::getoption $path -textvariable]
   69     if {  ![string length $var] } {
   70         set desc [BWidget::getname [Widget::getoption $path -name]]
   71         if { [llength $desc] } {
   72             set text  [lindex $desc 0]
   73             set under [lindex $desc 1]
   74             Widget::setoption $path -text $text
   75             Widget::setoption $path -underline $under
   76         } else {
   77             set text  [Widget::getoption $path -text]
   78             set under [Widget::getoption $path -underline]
   79         }
   80     } else {
   81         set under -1
   82         set text  ""
   83         Widget::setoption $path -underline $under
   84     }
   85 
   86     eval button $path [Widget::subcget $path :cmd] \
   87         [list -relief $relief -text $text -underline $under -textvariable $var]
   88     bindtags $path [list $path BwButton [winfo toplevel $path] all]
   89 
   90     set accel [string tolower [string index $text $under]]
   91     if { $accel != "" } {
   92         bind [winfo toplevel $path] <Alt-$accel> "Button::invoke $path"
   93     }
   94 
   95     DynamicHelp::sethelp $path $path 1
   96 
   97     rename $path ::$path:cmd
   98     proc ::$path { cmd args } "return \[eval Button::\$cmd $path \$args\]"
   99 
  100     return $path
  101 }
  102 
  103 
  104 # ------------------------------------------------------------------------------
  105 #  Command Button::configure
  106 # ------------------------------------------------------------------------------
  107 proc Button::configure { path args } {
  108     set oldunder [$path:cmd cget -underline]
  109     if { $oldunder != -1 } {
  110         set oldaccel [string tolower [string index [$path:cmd cget -text] $oldunder]]
  111     } else {
  112         set oldaccel ""
  113     }
  114     set res [Widget::configure $path $args]
  115 
  116     set rc [Widget::hasChanged $path -relief relief]
  117     set sc [Widget::hasChanged $path -state  state]
  118 
  119     if { $rc || $sc } {
  120         if { ![string compare $relief "link"] } {
  121             if { ![string compare $state "active"] } {
  122                 set relief "raised"
  123             } else {
  124                 set relief "flat"
  125             }
  126         }
  127         $path:cmd configure -relief $relief -state $state
  128     }
  129 
  130     set cv [Widget::hasChanged $path -textvariable var]
  131     set cn [Widget::hasChanged $path -name name]
  132     set ct [Widget::hasChanged $path -text text]
  133     set cu [Widget::hasChanged $path -underline under]
  134 
  135     if { $cv || $cn || $ct || $cu } {
  136         if {  ![string length $var] } {
  137             set desc [BWidget::getname $name]
  138             if { [llength $desc] } {
  139                 set text  [lindex $desc 0]
  140                 set under [lindex $desc 1]
  141             }
  142         } else {
  143             set under -1
  144             set text  ""
  145         }
  146         set top [winfo toplevel $path]
  147         bind $top <Alt-$oldaccel> {}
  148         set accel [string tolower [string index $text $under]]
  149         if { $accel != "" } {
  150             bind $top <Alt-$accel> "Button::invoke $path"
  151         }
  152         $path:cmd configure -text $text -underline $under -textvariable $var
  153     }
  154     DynamicHelp::sethelp $path $path
  155 
  156     return $res
  157 }
  158 
  159 
  160 # ------------------------------------------------------------------------------
  161 #  Command Button::cget
  162 # ------------------------------------------------------------------------------
  163 proc Button::cget { path option } {
  164     return [Widget::cget $path $option]
  165 }
  166 
  167 
  168 # ------------------------------------------------------------------------------
  169 #  Command Button::invoke
  170 # ------------------------------------------------------------------------------
  171 proc Button::invoke { path } {
  172     if { [string compare [$path:cmd cget -state] "disabled"] } {
  173     $path:cmd configure -state active -relief sunken
  174     update idletasks
  175         if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
  176             uplevel \#0 $cmd
  177         }
  178     after 100
  179         set relief [Widget::getoption $path -relief]
  180         if { ![string compare $relief "link"] } {
  181             set relief flat
  182         }
  183     $path:cmd configure \
  184             -state  [Widget::getoption $path -state] \
  185             -relief $relief
  186         if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
  187             uplevel \#0 $cmd
  188         }
  189         if { [set cmd [Widget::getoption $path -command]] != "" } {
  190             uplevel \#0 $cmd
  191         }
  192     }
  193 }
  194 
  195 
  196 # ------------------------------------------------------------------------------
  197 #  Command Button::_enter
  198 # ------------------------------------------------------------------------------
  199 proc Button::_enter { path } {
  200     variable _current
  201     variable _pressed
  202 
  203     set _current $path
  204     if { [string compare [$path:cmd cget -state] "disabled"] } {
  205         $path:cmd configure -state active
  206         if { $_pressed == $path } {
  207             $path:cmd configure -relief sunken
  208         } elseif { ![string compare [Widget::getoption $path -relief] "link"] } {
  209             $path:cmd configure -relief raised
  210         }
  211     }
  212 }
  213 
  214 
  215 # ------------------------------------------------------------------------------
  216 #  Command Button::_leave
  217 # ------------------------------------------------------------------------------
  218 proc Button::_leave { path } {
  219     variable _current
  220     variable _pressed
  221 
  222     set _current ""
  223     if { [string compare [$path:cmd cget -state] "disabled"] } {
  224         $path:cmd configure -state [Widget::getoption $path -state]
  225         set relief [Widget::getoption $path -relief]
  226         if { $_pressed == $path } {
  227             if { ![string compare $relief "link"] } {
  228                 set relief raised
  229             }
  230             $path:cmd configure -relief $relief
  231         } elseif { ![string compare $relief "link"] } {
  232             $path:cmd configure -relief flat
  233         }
  234     }
  235 }
  236 
  237 
  238 # ------------------------------------------------------------------------------
  239 #  Command Button::_press
  240 # ------------------------------------------------------------------------------
  241 proc Button::_press { path } {
  242     variable _pressed
  243 
  244     if { [string compare [$path:cmd cget -state] "disabled"] } {
  245         set _pressed $path
  246     $path:cmd configure -relief sunken
  247         if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
  248             uplevel \#0 $cmd
  249             if { [set delay [Widget::getoption $path -repeatdelay]]    > 0 ||
  250                  [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
  251                 after $delay "Button::_repeat $path"
  252             }
  253         }
  254     }
  255 }
  256 
  257 
  258 # ------------------------------------------------------------------------------
  259 #  Command Button::_release
  260 # ------------------------------------------------------------------------------
  261 proc Button::_release { path } {
  262     variable _current
  263     variable _pressed
  264 
  265     if { $_pressed == $path } {
  266         set _pressed ""
  267         set relief [Widget::getoption $path -relief]
  268         if { ![string compare $relief "link"] } {
  269             set relief raised
  270         }
  271         $path:cmd configure -relief $relief
  272         if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
  273             uplevel \#0 $cmd
  274         }
  275         if { $_current == $path &&
  276              [string compare [$path:cmd cget -state] "disabled"] &&
  277              [set cmd [Widget::getoption $path -command]] != "" } {
  278             uplevel \#0 $cmd
  279         }
  280     }
  281 }
  282 
  283 
  284 # ------------------------------------------------------------------------------
  285 #  Command Button::_repeat
  286 # ------------------------------------------------------------------------------
  287 proc Button::_repeat { path } {
  288     variable _current
  289     variable _pressed
  290 
  291     if { $_current == $path && $_pressed == $path &&
  292          [string compare [$path:cmd cget -state] "disabled"] &&
  293          [set cmd [Widget::getoption $path -armcommand]] != "" } {
  294         uplevel \#0 $cmd
  295     }
  296     if { $_pressed == $path &&
  297          ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
  298           [set delay [Widget::getoption $path -repeatdelay]]    > 0) } {
  299         after $delay "Button::_repeat $path"
  300     }
  301 }
  302