home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / widget.tcl < prev    next >
Text File  |  2000-11-02  |  34KB  |  973 lines
  1. # ------------------------------------------------------------------------------
  2. #  widget.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: widget.tcl,v 1.1.1.1 1996/02/22 06:05:56 daniel Exp $
  5. # ------------------------------------------------------------------------------
  6. #  Index of commands:
  7. #     - Widget::tkinclude
  8. #     - Widget::bwinclude
  9. #     - Widget::declare
  10. #     - Widget::addmap
  11. #     - Widget::init
  12. #     - Widget::destroy
  13. #     - Widget::setoption
  14. #     - Widget::configure
  15. #     - Widget::cget
  16. #     - Widget::subcget
  17. #     - Widget::hasChanged
  18. #     - Widget::_get_tkwidget_options
  19. #     - Widget::_test_tkresource
  20. #     - Widget::_test_bwresource
  21. #     - Widget::_test_synonym
  22. #     - Widget::_test_string
  23. #     - Widget::_test_flag
  24. #     - Widget::_test_enum
  25. #     - Widget::_test_int
  26. #     - Widget::_test_boolean
  27. # ------------------------------------------------------------------------------
  28.  
  29. namespace eval Widget {
  30.     variable _optiontype
  31.     variable _class
  32.     variable _tk_widget
  33.  
  34.     array set _optiontype {
  35.         TkResource Widget::_test_tkresource
  36.         BwResource Widget::_test_bwresource
  37.         Enum       Widget::_test_enum
  38.         Int        Widget::_test_int
  39.         Boolean    Widget::_test_boolean
  40.         String     Widget::_test_string
  41.         Flag       Widget::_test_flag
  42.         Synonym    Widget::_test_synonym
  43.     }
  44.  
  45.     proc use {} {}
  46. }
  47.  
  48.  
  49.  
  50. # ------------------------------------------------------------------------------
  51. #  Command Widget::tkinclude
  52. #     Includes tk widget resources to BWidget widget.
  53. #  class      class name of the BWidget
  54. #  tkwidget   tk widget to include
  55. #  subpath    subpath to configure
  56. #  args       additionnal args for included options
  57. # ------------------------------------------------------------------------------
  58. proc Widget::tkinclude { class tkwidget subpath args } {
  59.     foreach {cmd lopt} $args {
  60.         # cmd can be
  61.         #   include      options to include            lopt = {opt ...}
  62.         #   remove       options to remove             lopt = {opt ...}
  63.         #   rename       options to rename             lopt = {opt newopt ...}
  64.         #   prefix       options to prefix             lopt = {prefix opt opt ...}
  65.         #   initialize   set default value for options lopt = {opt value ...}
  66.         #   readonly     set readonly flag for options lopt = {opt flag ...}
  67.         switch -- $cmd {
  68.             remove {
  69.                 foreach option $lopt {
  70.                     set remove($option) 1
  71.                 }
  72.             }
  73.             include {
  74.                 foreach option $lopt {
  75.                     set include($option) 1
  76.                 }
  77.             }
  78.             prefix {
  79.                 set prefix [lindex $lopt 0]
  80.                 foreach option [lrange $lopt 1 end] {
  81.                     set rename($option) "-$prefix[string range $option 1 end]"
  82.                 }
  83.             }
  84.             rename     -
  85.             readonly   -
  86.             initialize {
  87.                 array set $cmd $lopt
  88.             }
  89.             default {
  90.                 return -code error "invalid argument \"$cmd\""
  91.             }
  92.         }
  93.     }
  94.  
  95.     namespace eval $class {}
  96.     upvar 0 ${class}::opt classopt
  97.     upvar 0 ${class}::map classmap
  98.  
  99.     # create resources informations from tk widget resources
  100.     foreach optdesc [_get_tkwidget_options $tkwidget] {
  101.         set option [lindex $optdesc 0]
  102.         if { (![info exists include] || [info exists include($option)]) &&
  103.              ![info exists remove($option)] } {
  104.             if { [llength $optdesc] == 3 } {
  105.                 # option is a synonym
  106.                 set syn [lindex $optdesc 1]
  107.                 if { ![info exists remove($syn)] } {
  108.                     # original option is not removed
  109.                     if { [info exists rename($syn)] } {
  110.                         set classopt($option) [list Synonym $rename($syn)]
  111.                     } else {
  112.                         set classopt($option) [list Synonym $syn]
  113.                     }
  114.                 }
  115.             } else {
  116.                 if { [info exists rename($option)] } {
  117.                     set realopt $option
  118.                     set option  $rename($option)
  119.                 } else {
  120.                     set realopt $option
  121.                 }
  122.                 if { [info exists initialize($option)] } {
  123.                     set value $initialize($option)
  124.                 } else {
  125.                     set value [lindex $optdesc 1]
  126.                 }
  127.                 if { [info exists readonly($option)] } {
  128.                     set ro $readonly($option)
  129.                 } else {
  130.                     set ro 0
  131.                 }
  132.                 set classopt($option) [list TkResource $value $ro [list $tkwidget $realopt]]
  133.                 lappend classmap($option) $subpath "" $realopt
  134.             }
  135.         }
  136.     }
  137. }
  138.  
  139.  
  140. # ------------------------------------------------------------------------------
  141. #  Command Widget::bwinclude
  142. #     Includes BWidget resources to BWidget widget.
  143. #  class    class name of the BWidget
  144. #  subclass BWidget class to include
  145. #  subpath  subpath to configure
  146. #  args     additionnal args for included options
  147. # ------------------------------------------------------------------------------
  148. proc Widget::bwinclude { class subclass subpath args } {
  149.     foreach {cmd lopt} $args {
  150.         # cmd can be
  151.         #   include      options to include            lopt = {opt ...}
  152.         #   remove       options to remove             lopt = {opt ...}
  153.         #   rename       options to rename             lopt = {opt newopt ...}
  154.         #   prefix       options to prefix             lopt = {prefix opt opt ...}
  155.         #   initialize   set default value for options lopt = {opt value ...}
  156.         #   readonly     set readonly flag for options lopt = {opt flag ...}
  157.         switch -- $cmd {
  158.             remove {
  159.                 foreach option $lopt {
  160.                     set remove($option) 1
  161.                 }
  162.             }
  163.             include {
  164.                 foreach option $lopt {
  165.                     set include($option) 1
  166.                 }
  167.             }
  168.             prefix {
  169.                 set prefix [lindex $lopt 0]
  170.                 foreach option [lrange $lopt 1 end] {
  171.                     set rename($option) "-$prefix[string range $option 1 end]"
  172.                 }
  173.             }
  174.             rename     -
  175.             readonly   -
  176.             initialize {
  177.                 array set $cmd $lopt
  178.             }
  179.             default {
  180.                 return -code error "invalid argument \"$cmd\""
  181.             }
  182.         }
  183.     }
  184.  
  185.     namespace eval $class {}
  186.     upvar 0 ${class}::opt classopt
  187.     upvar 0 ${class}::map classmap
  188.     upvar 0 ${subclass}::opt subclassopt
  189.  
  190.     # create resources informations from BWidget resources
  191.     foreach {option optdesc} [array get subclassopt] {
  192.         if { (![info exists include] || [info exists include($option)]) &&
  193.              ![info exists remove($option)] } {
  194.             set type [lindex $optdesc 0]
  195.             if { ![string compare $type "Synonym"] } {
  196.                 # option is a synonym
  197.                 set syn [lindex $optdesc 1]
  198.                 if { ![info exists remove($syn)] } {
  199.                     if { [info exists rename($syn)] } {
  200.                         set classopt($option) [list Synonym $rename($syn)]
  201.                     } else {
  202.                         set classopt($option) [list Synonym $syn]
  203.                     }
  204.                 }
  205.             } else {
  206.                 if { [info exists rename($option)] } {
  207.                     set realopt $option
  208.                     set option  $rename($option)
  209.                 } else {
  210.                     set realopt $option
  211.                 }
  212.                 if { [info exists initialize($option)] } {
  213.                     set value $initialize($option)
  214.                 } else {
  215.                     set value [lindex $optdesc 1]
  216.                 }
  217.                 if { [info exists readonly($option)] } {
  218.                     set ro $readonly($option)
  219.                 } else {
  220.                     set ro [lindex $optdesc 2]
  221.                 }
  222.                 set classopt($option) [list $type $value $ro [lindex $optdesc 3]]
  223.                 lappend classmap($option) $subpath $subclass $realopt
  224.             }
  225.         }
  226.     }
  227. }
  228.  
  229.  
  230. # ------------------------------------------------------------------------------
  231. #  Command Widget::declare
  232. #    Declares new options to BWidget class.
  233. # ------------------------------------------------------------------------------
  234. proc Widget::declare { class optlist } {
  235.     variable _optiontype
  236.  
  237.     namespace eval $class {}
  238.     upvar 0 ${class}::opt classopt
  239.  
  240.     foreach optdesc $optlist {
  241.         set option  [lindex $optdesc 0]
  242.         set optdesc [lrange $optdesc 1 end]
  243.         set type    [lindex $optdesc 0]
  244.  
  245.         if { ![info exists _optiontype($type)] } {
  246.             # invalid resource type
  247.             return -code error "invalid option type \"$type\""
  248.         }
  249.  
  250.         if { ![string compare $type "Synonym"] } {
  251.             # test existence of synonym option
  252.             set syn [lindex $optdesc 1]
  253.             if { ![info exists classopt($syn)] } {
  254.                 return -code error "unknow option \"$syn\" for Synonym \"$option\""
  255.             }
  256.             set classopt($option) [list Synonym $syn]
  257.             continue
  258.         }
  259.  
  260.         # all other resource may have default value, readonly flag and
  261.         # optional arg depending on type
  262.         set value [lindex $optdesc 1]
  263.         set ro    [lindex $optdesc 2]
  264.         set arg   [lindex $optdesc 3]
  265.  
  266.         if { ![string compare $type "BwResource"] } {
  267.             # We don't keep BwResource. We simplify to type of sub BWidget
  268.             set subclass    [lindex $arg 0]
  269.             set realopt     [lindex $arg 1]
  270.             if { ![string length $realopt] } {
  271.                 set realopt $option
  272.             }
  273.  
  274.             upvar 0 ${subclass}::opt subclassopt
  275.             if { ![info exists subclassopt($realopt)] } {
  276.                 return -code error "unknow option \"$realopt\""
  277.             }
  278.             set suboptdesc $subclassopt($realopt)
  279.             if { $value == "" } {
  280.                 # We initialize default value
  281.                 set value [lindex $suboptdesc 1]
  282.             }
  283.             set type [lindex $suboptdesc 0]
  284.             set ro   [lindex $suboptdesc 2]
  285.             set arg  [lindex $suboptdesc 3]
  286.             set classopt($option) [list $type $value $ro $arg]
  287.             continue
  288.         }
  289.  
  290.         # retreive default value for TkResource
  291.         if { ![string compare $type "TkResource"] } {
  292.             set tkwidget [lindex $arg 0]
  293.             set realopt  [lindex $arg 1]
  294.             if { ![string length $realopt] } {
  295.                 set realopt $option
  296.             }
  297.             set tkoptions [_get_tkwidget_options $tkwidget]
  298.             if { ![string length $value] } {
  299.                 # We initialize default value
  300.                 set value [lindex [lindex $tkoptions [lsearch $tkoptions [list $realopt *]]] end]
  301.             }
  302.             set classopt($option) [list TkResource $value $ro [list $tkwidget $realopt]]
  303.             continue
  304.         }
  305.  
  306.         # for any other resource type, we keep original optdesc
  307.         set classopt($option) [list $type $value $ro $arg]
  308.     }
  309. }
  310.  
  311.  
  312. # ------------------------------------------------------------------------------
  313. #  Command Widget::addmap
  314. # ------------------------------------------------------------------------------
  315. proc Widget::addmap { class subclass subpath options } {
  316.     upvar 0 ${class}::map classmap
  317.  
  318.     foreach {option realopt} $options {
  319.         if { ![string length $realopt] } {
  320.             set realopt $option
  321.         }
  322.         lappend classmap($option) $subpath $subclass $realopt
  323.     }
  324. }
  325.  
  326.  
  327. # ------------------------------------------------------------------------------
  328. #  Command Widget::syncoptions
  329. # ------------------------------------------------------------------------------
  330. proc Widget::syncoptions { class subclass subpath options } {
  331.     upvar 0 ${class}::sync classync
  332.  
  333.     foreach {option realopt} $options {
  334.         if { ![string length $realopt] } {
  335.             set realopt $option
  336.         }
  337.         set classync($option) [list $subpath $subclass $realopt]
  338.     }
  339. }
  340.  
  341.  
  342. # ------------------------------------------------------------------------------
  343. #  Command Widget::init
  344. # ------------------------------------------------------------------------------
  345. proc Widget::init { class path options } {
  346.     variable _class
  347.     variable _optiontype
  348.  
  349.     upvar 0 ${class}::opt classopt
  350.     upvar 0 ${class}::map classmap
  351.     upvar 0 ${class}::$path:opt  pathopt
  352.     upvar 0 ${class}::$path:mod  pathmod
  353.  
  354.     catch {unset pathopt}
  355.     catch {unset pathmod}
  356.     set fpath ".#BWidgetClass#$class"
  357.     regsub -all "::" $class "" rdbclass
  358.     if { ![winfo exists $fpath] } {
  359.         frame $fpath -class $rdbclass
  360.     }
  361.     foreach {option optdesc} [array get classopt] {
  362.         set type [lindex $optdesc 0]
  363.         if { ![string compare $type "Synonym"] } {
  364.             set option  [lindex $optdesc 1]
  365.             set optdesc $classopt($option)
  366.             set type    [lindex $optdesc 0]
  367.         }
  368.         if { ![string compare $type "TkResource"] } {
  369.             set alt [lindex [lindex $optdesc 3] 1]
  370.         } else {
  371.             set alt ""
  372.         }
  373.         set optdb [lindex [_configure_option $option $alt] 0]
  374.         set def   [option get $fpath $optdb $rdbclass]
  375.         if { [string length $def] } {
  376.             set pathopt($option) $def
  377.         } else {
  378.             set pathopt($option) [lindex $optdesc 1]
  379.         }
  380.         set pathmod($option) 0
  381.     }
  382.  
  383.     set _class($path) $class
  384.     foreach {option value} $options {
  385.         if { ![info exists classopt($option)] } {
  386.             unset pathopt
  387.             unset pathmod
  388.             return -code error "unknown option \"$option\""
  389.         }
  390.         set optdesc $classopt($option)
  391.         set type    [lindex $optdesc 0]
  392.         if { ![string compare $type "Synonym"] } {
  393.             set option  [lindex $optdesc 1]
  394.             set optdesc $classopt($option)
  395.             set type    [lindex $optdesc 0]
  396.         }
  397.         set pathopt($option) [$_optiontype($type) $option $value [lindex $optdesc 3]]
  398.     }
  399. }
  400.  
  401.  
  402. # ------------------------------------------------------------------------------
  403. #  Command Widget::destroy
  404. # ------------------------------------------------------------------------------
  405. proc Widget::destroy { path } {
  406.     variable _class
  407.  
  408.     set class $_class($path)
  409.     upvar 0 ${class}::$path:opt pathopt
  410.     upvar 0 ${class}::$path:mod pathmod
  411.  
  412.     catch {unset pathopt}
  413.     catch {unset pathmod}
  414. }
  415.  
  416.  
  417. # ------------------------------------------------------------------------------
  418. #  Command Widget::configure
  419. # ------------------------------------------------------------------------------
  420. proc Widget::configure { path options } {
  421.     set len [llength $options]
  422.     if { $len <= 1 } {
  423.         return [_get_configure $path $options]
  424.     } elseif { $len % 2 == 1 } {
  425.         return -code error "incorrect number of arguments"
  426.     }
  427.  
  428.     variable _class
  429.     variable _optiontype
  430.  
  431.     set class $_class($path)
  432.     upvar 0 ${class}::opt  classopt
  433.     upvar 0 ${class}::map  classmap
  434.     upvar 0 ${class}::$path:opt pathopt
  435.     upvar 0 ${class}::$path:mod pathmod
  436.  
  437.     set window [_get_window $class $path]
  438.     foreach {option value} $options {
  439.         if { ![info exists classopt($option)] } {
  440.             return -code error "unknown option \"$option\""
  441.         }
  442.         set optdesc $classopt($option)
  443.         set type    [lindex $optdesc 0]
  444.         if { ![string compare $type "Synonym"] } {
  445.             set option  [lindex $optdesc 1]
  446.             set optdesc $classopt($option)
  447.             set type    [lindex $optdesc 0]
  448.         }
  449.         if { ![lindex $optdesc 2] } {
  450.             set curval $pathopt($option)
  451.             set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
  452.             if { [info exists classmap($option)] } {
  453.                 foreach {subpath subclass realopt} $classmap($option) {
  454.                     if { [string length $subclass] } {
  455.                         ${subclass}::configure $window$subpath $realopt $newval
  456.                     } else {
  457.                         $window$subpath configure $realopt $newval
  458.                     }
  459.                 }
  460.             }
  461.             set pathopt($option) $newval
  462.             set pathmod($option) [expr {[string compare $newval $curval] != 0}]
  463.         }
  464.     }
  465.  
  466.     return {}
  467. }
  468.  
  469.  
  470. # ------------------------------------------------------------------------------
  471. #  Command Widget::cget
  472. # ------------------------------------------------------------------------------
  473. proc Widget::cget { path option } {
  474.     variable _class
  475.  
  476.     if { ![info exists _class($path)] } {
  477.         return -code error "unknown widget $path"
  478.     }
  479.  
  480.     set class $_class($path)
  481.     upvar 0 ${class}::opt  classopt
  482.     upvar 0 ${class}::sync classync
  483.     upvar 0 ${class}::$path:opt pathopt
  484.  
  485.     if { ![info exists classopt($option)] } {
  486.         return -code error "unknown option \"$option\""
  487.     }
  488.     set optdesc $classopt($option)
  489.     set type    [lindex $optdesc 0]
  490.     if { ![string compare $type "Synonym"] } {
  491.         set option [lindex $optdesc 1]
  492.     }
  493.  
  494.     if { [info exists classync($option)] } {
  495.         set window [_get_window $class $path]
  496.         foreach {subpath subclass realopt} $classync($option) {
  497.             if { [string length $subclass] } {
  498.                 set pathopt($option) [${subclass}::cget $window$subpath $realopt]
  499.             } else {
  500.                 set pathopt($option) [$window$subpath cget $realopt]
  501.             }
  502.         }
  503.     }
  504.  
  505.     return $pathopt($option)
  506. }
  507.  
  508.  
  509. # ------------------------------------------------------------------------------
  510. #  Command Widget::subcget
  511. # ------------------------------------------------------------------------------
  512. proc Widget::subcget { path subwidget } {
  513.     variable _class
  514.  
  515.     set class $_class($path)
  516.     upvar 0 ${class}::map classmap
  517.     upvar 0 ${class}::$path:opt pathopt
  518.  
  519.     set result {}
  520.     foreach {option map} [array get classmap] {
  521.         foreach {subpath subclass realopt} $map {
  522.             if { ![string compare $subpath $subwidget] } {
  523.                 lappend result $realopt $pathopt($option)
  524.             }
  525.         }
  526.     }
  527.     return $result
  528. }
  529.  
  530.  
  531. # ------------------------------------------------------------------------------
  532. #  Command Widget::hasChanged
  533. # ------------------------------------------------------------------------------
  534. proc Widget::hasChanged { path option pvalue } {
  535.     upvar    $pvalue value
  536.     variable _class
  537.  
  538.     set class $_class($path)
  539.     upvar 0 ${class}::$path:opt pathopt
  540.     upvar 0 ${class}::$path:mod pathmod
  541.  
  542.     set value   $pathopt($option)
  543.     set result  $pathmod($option)
  544.     set pathmod($option) 0
  545.  
  546.     return $result
  547. }
  548.  
  549.  
  550. # ------------------------------------------------------------------------------
  551. #  Command Widget::setoption
  552. # ------------------------------------------------------------------------------
  553. proc Widget::setoption { path option value } {
  554.     variable _class
  555.  
  556.     set class $_class($path)
  557.     upvar 0 ${class}::$path:opt pathopt
  558.  
  559.     set pathopt($option) $value
  560. }
  561.  
  562.  
  563. # ------------------------------------------------------------------------------
  564. #  Command Widget::getoption
  565. # ------------------------------------------------------------------------------
  566. proc Widget::getoption { path option } {
  567.     variable _class
  568.  
  569.     set class $_class($path)
  570.     upvar 0 ${class}::$path:opt pathopt
  571.  
  572.     return $pathopt($option)
  573. }
  574.  
  575.  
  576. # ------------------------------------------------------------------------------
  577. #  Command Widget::_get_window
  578. #  returns the window corresponding to widget path
  579. # ------------------------------------------------------------------------------
  580. proc Widget::_get_window { class path } {
  581.     set idx [string last "#" $path]
  582.     if { $idx != -1 && ![string compare [string range $path [expr {$idx+1}] end] $class] } {
  583.         return [string range $path 0 [expr {$idx-1}]]
  584.     } else {
  585.         return $path
  586.     }
  587. }
  588.  
  589.  
  590. # ------------------------------------------------------------------------------
  591. #  Command Widget::_get_configure
  592. #  returns the configuration list of options
  593. #  (as tk widget do - [$w configure ?option?])
  594. # ------------------------------------------------------------------------------
  595. proc Widget::_get_configure { path options } {
  596.     variable _class
  597.  
  598.     set class $_class($path)
  599.     upvar 0 ${class}::opt classopt
  600.     upvar 0 ${class}::map classmap
  601.     upvar 0 ${class}::$path:opt pathopt
  602.     upvar 0 ${class}::$path:mod pathmod
  603.  
  604.     set len [llength $options]
  605.     if { !$len } {
  606.         set result {}
  607.         foreach option [lsort [array names classopt]] {
  608.             set optdesc $classopt($option)
  609.             set type    [lindex $optdesc 0]
  610.             if { ![string compare $type "Synonym"] } {
  611.                 set syn     $option
  612.                 set option  [lindex $optdesc 1]
  613.                 set optdesc $classopt($option)
  614.                 set type    [lindex $optdesc 0]
  615.             } else {
  616.                 set syn ""
  617.             }
  618.             if { ![string compare $type "TkResource"] } {
  619.                 set alt [lindex [lindex $optdesc 3] 1]
  620.             } else {
  621.                 set alt ""
  622.             }
  623.             set res [_configure_option $option $alt]
  624.             if { $syn == "" } {
  625.                 lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
  626.             } else {
  627.                 lappend result [list $syn [lindex $res 0]]
  628.             }
  629.         }
  630.         return $result
  631.     } elseif { $len == 1 } {
  632.         set option  [lindex $options 0]
  633.         if { ![info exists classopt($option)] } {
  634.             return -code error "unknown option \"$option\""
  635.         }
  636.         set optdesc $classopt($option)
  637.         set type    [lindex $optdesc 0]
  638.         if { ![string compare $type "Synonym"] } {
  639.             set option  [lindex $optdesc 1]
  640.             set optdesc $classopt($option)
  641.             set type    [lindex $optdesc 0]
  642.         }
  643.         if { ![string compare $type "TkResource"] } {
  644.             set alt [lindex [lindex $optdesc 3] 1]
  645.         } else {
  646.             set alt ""
  647.         }
  648.         set res [_configure_option $option $alt]
  649.         return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
  650.     }
  651. }
  652.  
  653.  
  654. # ------------------------------------------------------------------------------
  655. #  Command Widget::_configure_option
  656. # ------------------------------------------------------------------------------
  657. proc Widget::_configure_option { option altopt } {
  658.     variable _optiondb
  659.     variable _optionclass
  660.  
  661.     if { [info exists _optiondb($option)] } {
  662.         set optdb $_optiondb($option)
  663.     } else {
  664.         set optdb [string range $option 1 end]
  665.     }
  666.     if { [info exists _optionclass($option)] } {
  667.         set optclass $_optionclass($option)
  668.     } elseif { [string length $altopt] } {
  669.         if { [info exists _optionclass($altopt)] } {
  670.             set optclass $_optionclass($altopt)
  671.         } else {
  672.             set optclass [string range $altopt 1 end]
  673.         }
  674.     } else {
  675.         set optclass [string range $option 1 end]
  676.     }
  677.     return [list $optdb $optclass]
  678. }
  679.  
  680.  
  681. # ------------------------------------------------------------------------------
  682. #  Command Widget::_get_tkwidget_options
  683. # ------------------------------------------------------------------------------
  684. proc Widget::_get_tkwidget_options { tkwidget } {
  685.     variable _tk_widget
  686.     variable _optiondb
  687.     variable _optionclass
  688.  
  689.     if { ![info exists _tk_widget($tkwidget)] } {
  690.         set widget [$tkwidget ".#BWidget#$tkwidget"]
  691.         set config [$widget configure]
  692.         foreach optlist $config {
  693.             set opt [lindex $optlist 0]
  694.             if { [llength $optlist] == 2 } {
  695.                 set refsyn [lindex $optlist 1]
  696.                 # search for class
  697.                 set idx [lsearch $config [list * $refsyn *]]
  698.                 if { $idx == -1 } {
  699.                     if { [string index $refsyn 0] == "-" } {
  700.                         # search for option (tk8.1b1 bug)
  701.                         set idx [lsearch $config [list $refsyn * *]]
  702.                     } else {
  703.                         # last resort
  704.                         set idx [lsearch $config [list -[string tolower $refsyn] * *]]
  705.                     }
  706.                     if { $idx == -1 } {
  707.                         # fed up with "can't read classopt()"
  708.                         return -code error "can't find option of synonym $opt"
  709.                     }
  710.                 }
  711.                 set syn [lindex [lindex $config $idx] 0]
  712.                 set def [lindex [lindex $config $idx] 3]
  713.                 lappend _tk_widget($tkwidget) [list $opt $syn $def]
  714.             } else {
  715.                 set def [lindex $optlist 3]
  716.                 lappend _tk_widget($tkwidget) [list $opt $def]
  717.                 set _optiondb($opt)    [lindex $optlist 1]
  718.                 set _optionclass($opt) [lindex $optlist 2]
  719.             }
  720.         }
  721.     }
  722.     return $_tk_widget($tkwidget)
  723. }
  724.  
  725.  
  726. # ------------------------------------------------------------------------------
  727. #  Command Widget::_test_tkresource
  728. # ------------------------------------------------------------------------------
  729. proc Widget::_test_tkresource { option value arg } {
  730.     set tkwidget [lindex $arg 0]
  731.     set realopt  [lindex $arg 1]
  732.     set path     ".#BWidget#$tkwidget"
  733.     set old      [$path cget $realopt]
  734.     $path configure $realopt $value
  735.     set res      [$path cget $realopt]
  736.     $path configure $realopt $old
  737.  
  738.     return $res
  739. }
  740.  
  741.  
  742. # ------------------------------------------------------------------------------
  743. #  Command Widget::_test_bwresource
  744. # ------------------------------------------------------------------------------
  745. proc Widget::_test_bwresource { option value arg } {
  746.     return -code error "bad option type BwResource in widget"
  747. }
  748.  
  749.  
  750. # ------------------------------------------------------------------------------
  751. #  Command Widget::_test_synonym
  752. # ------------------------------------------------------------------------------
  753. proc Widget::_test_synonym { option value arg } {
  754.     return -code error "bad option type Synonym in widget"
  755. }
  756.  
  757.  
  758. # ------------------------------------------------------------------------------
  759. #  Command Widget::_test_string
  760. # ------------------------------------------------------------------------------
  761. proc Widget::_test_string { option value arg } {
  762.     return $value
  763. }
  764.  
  765.  
  766. # ------------------------------------------------------------------------------
  767. #  Command Widget::_test_flag
  768. # ------------------------------------------------------------------------------
  769. proc Widget::_test_flag { option value arg } {
  770.     set len [string length $value]
  771.     set res ""
  772.     for {set i 0} {$i < $len} {incr i} {
  773.         set c [string index $value $i]
  774.         if { [string first $c $arg] == -1 } {
  775.             return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
  776.         }
  777.         if { [string first $c $res] == -1 } {
  778.             append res $c
  779.         }
  780.     }
  781.     return $res
  782. }
  783.  
  784.  
  785. # ------------------------------------------------------------------------------
  786. #  Command Widget::_test_enum
  787. # ------------------------------------------------------------------------------
  788. proc Widget::_test_enum { option value arg } {
  789.     if { [lsearch $arg $value] == -1 } {
  790.         set last [lindex   $arg end]
  791.         set sub  [lreplace $arg end end]
  792.         if { [llength $sub] } {
  793.             set str "[join $sub ", "] or $last"
  794.         } else {
  795.             set str $last
  796.         }
  797.         return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
  798.     }
  799.     return $value
  800. }
  801.  
  802.  
  803. # ------------------------------------------------------------------------------
  804. #  Command Widget::_test_int
  805. # ------------------------------------------------------------------------------
  806. proc Widget::_test_int { option value arg } {
  807.     set binf [lindex $arg 0]
  808.     set bsup [lindex $arg 1]
  809.     if { $binf != "" } {set binf ">$binf"}
  810.     if { $bsup != "" } {set bsup "<$bsup"}
  811.     if { [catch {expr $value}] || $value != int($value) ||
  812.          !($binf == "" || [expr $value$binf]) ||
  813.          !($bsup == "" || [expr $value$bsup]) } {
  814.         return -code error "bad [string range $option 1 end] value \"$value\": must be integer $binf $bsup"
  815.     }
  816.     return $value
  817. }
  818.  
  819.  
  820. # ------------------------------------------------------------------------------
  821. #  Command Widget::_test_boolean
  822. # ------------------------------------------------------------------------------
  823. proc Widget::_test_boolean { option value arg } {
  824.     if { $value == 1 ||
  825.          ![string compare $value "true"] ||
  826.          ![string compare $value "yes"] } {
  827.         set value 1
  828.     } elseif { $value == 0 ||
  829.                ![string compare $value "false"] ||
  830.                ![string compare $value "no"] } {
  831.         set value 0
  832.     } else {
  833.         return -code error "bad [string range $option 1 end] value \"$value\": must be boolean"
  834.     }
  835.     return $value
  836. }
  837.  
  838.  
  839. # ------------------------------------------------------------------------------
  840. #  Command Widget::focusNext
  841. #  Same as tk_focusNext, but call Widget::focusOK
  842. # ------------------------------------------------------------------------------
  843. proc Widget::focusNext { w } {
  844.     set cur $w
  845.     while 1 {
  846.  
  847.     # Descend to just before the first child of the current widget.
  848.  
  849.     set parent $cur
  850.     set children [winfo children $cur]
  851.     set i -1
  852.  
  853.     # Look for the next sibling that isn't a top-level.
  854.  
  855.     while 1 {
  856.         incr i
  857.         if {$i < [llength $children]} {
  858.         set cur [lindex $children $i]
  859.         if {[winfo toplevel $cur] == $cur} {
  860.             continue
  861.         } else {
  862.             break
  863.         }
  864.         }
  865.  
  866.         # No more siblings, so go to the current widget's parent.
  867.         # If it's a top-level, break out of the loop, otherwise
  868.         # look for its next sibling.
  869.  
  870.         set cur $parent
  871.         if {[winfo toplevel $cur] == $cur} {
  872.         break
  873.         }
  874.         set parent [winfo parent $parent]
  875.         set children [winfo children $parent]
  876.         set i [lsearch -exact $children $cur]
  877.     }
  878.     if {($cur == $w) || [focusOK $cur]} {
  879.         return $cur
  880.     }
  881.     }
  882. }
  883.  
  884.  
  885. # ------------------------------------------------------------------------------
  886. #  Command Widget::focusPrev
  887. #  Same as tk_focusPrev, but call Widget::focusOK
  888. # ------------------------------------------------------------------------------
  889. proc Widget::focusPrev { w } {
  890.     set cur $w
  891.     while 1 {
  892.  
  893.     # Collect information about the current window's position
  894.     # among its siblings.  Also, if the window is a top-level,
  895.     # then reposition to just after the last child of the window.
  896.     
  897.     if {[winfo toplevel $cur] == $cur}  {
  898.         set parent $cur
  899.         set children [winfo children $cur]
  900.         set i [llength $children]
  901.     } else {
  902.         set parent [winfo parent $cur]
  903.         set children [winfo children $parent]
  904.         set i [lsearch -exact $children $cur]
  905.     }
  906.  
  907.     # Go to the previous sibling, then descend to its last descendant
  908.     # (highest in stacking order.  While doing this, ignore top-levels
  909.     # and their descendants.  When we run out of descendants, go up
  910.     # one level to the parent.
  911.  
  912.     while {$i > 0} {
  913.         incr i -1
  914.         set cur [lindex $children $i]
  915.         if {[winfo toplevel $cur] == $cur} {
  916.         continue
  917.         }
  918.         set parent $cur
  919.         set children [winfo children $parent]
  920.         set i [llength $children]
  921.     }
  922.     set cur $parent
  923.     if {($cur == $w) || [focusOK $cur]} {
  924.         return $cur
  925.     }
  926.     }
  927. }
  928.  
  929.  
  930. # ------------------------------------------------------------------------------
  931. #  Command Widget::focusOK
  932. #  Same as tk_focusOK, but handles -editable option and whole tags list.
  933. # ------------------------------------------------------------------------------
  934. proc Widget::focusOK { w } {
  935.     set code [catch {$w cget -takefocus} value]
  936.     if { $code == 1 } {
  937.         return 0
  938.     }
  939.     if {($code == 0) && ($value != "")} {
  940.     if {$value == 0} {
  941.         return 0
  942.     } elseif {$value == 1} {
  943.         return [winfo viewable $w]
  944.     } else {
  945.         set value [uplevel \#0 $value $w]
  946.             if {$value != ""} {
  947.         return $value
  948.         }
  949.         }
  950.     }
  951.     if {![winfo viewable $w]} {
  952.     return 0
  953.     }
  954.     set code [catch {$w cget -state} value]
  955.     if {($code == 0) && ($value == "disabled")} {
  956.     return 0
  957.     }
  958.     set code [catch {$w cget -editable} value]
  959.     if {($code == 0) && !$value} {
  960.         return 0
  961.     }
  962.  
  963.     set top [winfo toplevel $w]
  964.     foreach tags [bindtags $w] {
  965.         if { [string compare $tags $top]  &&
  966.              [string compare $tags "all"] &&
  967.              [regexp Key [bind $tags]] } {
  968.             return 1
  969.         }
  970.     }
  971.     return 0
  972. }
  973.