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 / widget.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  41.1 KB  |  1,263 lines
  1. # ------------------------------------------------------------------------------
  2. #  widget.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: widget.tcl,v 1.17 2001/06/11 23:58:40 hobbs 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. # Each megawidget gets a namespace of the same name inside the Widget namespace
  29. # Each of these has an array opt, which contains information about the 
  30. # megawidget options.  It maps megawidget options to a list with this format:
  31. #     {optionType defaultValue isReadonly {additionalOptionalInfo}}
  32. # Option types and their additional optional info are:
  33. #    TkResource    {genericTkWidget genericTkWidgetOptionName}
  34. #    BwResource    {nothing}
  35. #    Enum        {list of enumeration values}
  36. #    Int        {Boundary information}
  37. #    Boolean        {nothing}
  38. #    String        {nothing}
  39. #    Flag        {string of valid flag characters}
  40. #    Synonym        {nothing}
  41. #
  42. # Next, each namespace has an array map, which maps class options to their
  43. # component widget options:
  44. #    map(-foreground) => {.e -foreground .f -foreground}
  45. #
  46. # Each has an array ${path}:opt, which contains the value of each megawidget
  47. # option for a particular instance $path of the megawidget, and an array
  48. # ${path}:mod, which stores the "changed" status of configuration options.
  49.  
  50. # Steps for creating a bwidget megawidget:
  51. # 1. parse args to extract subwidget spec
  52. # 2. Create frame with appropriate class and command line options
  53. # 3. Get initialization options from optionDB, using frame
  54. # 4. create subwidgets
  55.  
  56. # Uses newer string operations
  57. package require Tcl 8.1.1
  58.  
  59. namespace eval Widget {
  60.     variable _optiontype
  61.     variable _class
  62.     variable _tk_widget
  63.  
  64.     array set _optiontype {
  65.         TkResource Widget::_test_tkresource
  66.         BwResource Widget::_test_bwresource
  67.         Enum       Widget::_test_enum
  68.         Int        Widget::_test_int
  69.         Boolean    Widget::_test_boolean
  70.         String     Widget::_test_string
  71.         Flag       Widget::_test_flag
  72.         Synonym    Widget::_test_synonym
  73.     }
  74.  
  75.     proc use {} {}
  76. }
  77.  
  78.  
  79.  
  80. # ------------------------------------------------------------------------------
  81. #  Command Widget::tkinclude
  82. #     Includes tk widget resources to BWidget widget.
  83. #  class      class name of the BWidget
  84. #  tkwidget   tk widget to include
  85. #  subpath    subpath to configure
  86. #  args       additionnal args for included options
  87. # ------------------------------------------------------------------------------
  88. proc Widget::tkinclude { class tkwidget subpath args } {
  89.     foreach {cmd lopt} $args {
  90.         # cmd can be
  91.         #   include      options to include            lopt = {opt ...}
  92.         #   remove       options to remove             lopt = {opt ...}
  93.         #   rename       options to rename             lopt = {opt newopt ...}
  94.         #   prefix       options to prefix             lopt = {pref opt opt ..}
  95.         #   initialize   set default value for options lopt = {opt value ...}
  96.         #   readonly     set readonly flag for options lopt = {opt flag ...}
  97.         switch -- $cmd {
  98.             remove {
  99.                 foreach option $lopt {
  100.                     set remove($option) 1
  101.                 }
  102.             }
  103.             include {
  104.                 foreach option $lopt {
  105.                     set include($option) 1
  106.                 }
  107.             }
  108.             prefix {
  109.                 set prefix [lindex $lopt 0]
  110.                 foreach option [lrange $lopt 1 end] {
  111.                     set rename($option) "-$prefix[string range $option 1 end]"
  112.                 }
  113.             }
  114.             rename     -
  115.             readonly   -
  116.             initialize {
  117.                 array set $cmd $lopt
  118.             }
  119.             default {
  120.                 return -code error "invalid argument \"$cmd\""
  121.             }
  122.         }
  123.     }
  124.  
  125.     namespace eval $class {}
  126.     upvar 0 ${class}::opt classopt
  127.     upvar 0 ${class}::map classmap
  128.     upvar 0 ${class}::map$subpath submap
  129.     upvar 0 ${class}::optionExports exports
  130.  
  131.     set foo [$tkwidget ".ericFoo###"]
  132.     # create resources informations from tk widget resources
  133.     foreach optdesc [_get_tkwidget_options $tkwidget] {
  134.         set option [lindex $optdesc 0]
  135.         if { (![info exists include] || [info exists include($option)]) &&
  136.              ![info exists remove($option)] } {
  137.             if { [llength $optdesc] == 3 } {
  138.                 # option is a synonym
  139.                 set syn [lindex $optdesc 1]
  140.                 if { ![info exists remove($syn)] } {
  141.                     # original option is not removed
  142.                     if { [info exists rename($syn)] } {
  143.                         set classopt($option) [list Synonym $rename($syn)]
  144.                     } else {
  145.                         set classopt($option) [list Synonym $syn]
  146.                     }
  147.                 }
  148.             } else {
  149.                 if { [info exists rename($option)] } {
  150.                     set realopt $option
  151.                     set option  $rename($option)
  152.                 } else {
  153.                     set realopt $option
  154.                 }
  155.                 if { [info exists initialize($option)] } {
  156.                     set value $initialize($option)
  157.                 } else {
  158.                     set value [lindex $optdesc 1]
  159.                 }
  160.                 if { [info exists readonly($option)] } {
  161.                     set ro $readonly($option)
  162.                 } else {
  163.                     set ro 0
  164.                 }
  165.                 set classopt($option) \
  166.             [list TkResource $value $ro [list $tkwidget $realopt]]
  167.  
  168.         # Add an option database entry for this option
  169.         set optionDbName ".[lindex [_configure_option $option ""] 0]"
  170.         if { ![string equal $subpath ":cmd"] } {
  171.             set optionDbName "$subpath$optionDbName"
  172.         }
  173.         option add *${class}$optionDbName $value widgetDefault
  174.         lappend exports($option) "$optionDbName"
  175.  
  176.         # Store the forward and backward mappings for this
  177.         # option <-> realoption pair
  178.                 lappend classmap($option) $subpath "" $realopt
  179.         set submap($realopt) $option
  180.             }
  181.         }
  182.     }
  183.     ::destroy $foo
  184. }
  185.  
  186.  
  187. # ------------------------------------------------------------------------------
  188. #  Command Widget::bwinclude
  189. #     Includes BWidget resources to BWidget widget.
  190. #  class    class name of the BWidget
  191. #  subclass BWidget class to include
  192. #  subpath  subpath to configure
  193. #  args     additionnal args for included options
  194. # ------------------------------------------------------------------------------
  195. proc Widget::bwinclude { class subclass subpath args } {
  196.     foreach {cmd lopt} $args {
  197.         # cmd can be
  198.         #   include      options to include            lopt = {opt ...}
  199.         #   remove       options to remove             lopt = {opt ...}
  200.         #   rename       options to rename             lopt = {opt newopt ...}
  201.         #   prefix       options to prefix             lopt = {prefix opt opt ...}
  202.         #   initialize   set default value for options lopt = {opt value ...}
  203.         #   readonly     set readonly flag for options lopt = {opt flag ...}
  204.         switch -- $cmd {
  205.             remove {
  206.                 foreach option $lopt {
  207.                     set remove($option) 1
  208.                 }
  209.             }
  210.             include {
  211.                 foreach option $lopt {
  212.                     set include($option) 1
  213.                 }
  214.             }
  215.             prefix {
  216.                 set prefix [lindex $lopt 0]
  217.                 foreach option [lrange $lopt 1 end] {
  218.                     set rename($option) "-$prefix[string range $option 1 end]"
  219.                 }
  220.             }
  221.             rename     -
  222.             readonly   -
  223.             initialize {
  224.                 array set $cmd $lopt
  225.             }
  226.             default {
  227.                 return -code error "invalid argument \"$cmd\""
  228.             }
  229.         }
  230.     }
  231.  
  232.     namespace eval $class {}
  233.     upvar 0 ${class}::opt classopt
  234.     upvar 0 ${class}::map classmap
  235.     upvar 0 ${class}::map$subpath submap
  236.     upvar 0 ${class}::optionExports exports
  237.     upvar 0 ${subclass}::opt subclassopt
  238.     upvar 0 ${subclass}::optionExports subexports
  239.  
  240.     # create resources informations from BWidget resources
  241.     foreach {option optdesc} [array get subclassopt] {
  242.     set subOption $option
  243.         if { (![info exists include] || [info exists include($option)]) &&
  244.              ![info exists remove($option)] } {
  245.             set type [lindex $optdesc 0]
  246.             if { ![string compare $type "Synonym"] } {
  247.                 # option is a synonym
  248.                 set syn [lindex $optdesc 1]
  249.                 if { ![info exists remove($syn)] } {
  250.                     if { [info exists rename($syn)] } {
  251.                         set classopt($option) [list Synonym $rename($syn)]
  252.                     } else {
  253.                         set classopt($option) [list Synonym $syn]
  254.                     }
  255.                 }
  256.             } else {
  257.                 if { [info exists rename($option)] } {
  258.                     set realopt $option
  259.                     set option  $rename($option)
  260.                 } else {
  261.                     set realopt $option
  262.                 }
  263.                 if { [info exists initialize($option)] } {
  264.                     set value $initialize($option)
  265.                 } else {
  266.                     set value [lindex $optdesc 1]
  267.                 }
  268.                 if { [info exists readonly($option)] } {
  269.                     set ro $readonly($option)
  270.                 } else {
  271.                     set ro [lindex $optdesc 2]
  272.                 }
  273.                 set classopt($option) \
  274.             [list $type $value $ro [lindex $optdesc 3]]
  275.  
  276.         # Add an option database entry for this option
  277.         foreach optionDbName $subexports($subOption) {
  278.             if { ![string equal $subpath ":cmd"] } {
  279.             set optionDbName "$subpath$optionDbName"
  280.             }
  281.             # Only add the option db entry if we are overriding the
  282.             # normal widget default
  283.             if { [info exists initialize($option)] } {
  284.             option add *${class}$optionDbName $value \
  285.                 widgetDefault
  286.             }
  287.             lappend exports($option) "$optionDbName"
  288.         }
  289.  
  290.         # Store the forward and backward mappings for this
  291.         # option <-> realoption pair
  292.                 lappend classmap($option) $subpath $subclass $realopt
  293.         set submap($realopt) $option
  294.             }
  295.         }
  296.     }
  297. }
  298.  
  299.  
  300. # ------------------------------------------------------------------------------
  301. #  Command Widget::declare
  302. #    Declares new options to BWidget class.
  303. # ------------------------------------------------------------------------------
  304. proc Widget::declare { class optlist } {
  305.     variable _optiontype
  306.  
  307.     namespace eval $class {}
  308.     upvar 0 ${class}::opt classopt
  309.     upvar 0 ${class}::optionExports exports
  310.     upvar 0 ${class}::optionClass optionClass
  311.  
  312.     foreach optdesc $optlist {
  313.         set option  [lindex $optdesc 0]
  314.         set optdesc [lrange $optdesc 1 end]
  315.         set type    [lindex $optdesc 0]
  316.  
  317.         if { ![info exists _optiontype($type)] } {
  318.             # invalid resource type
  319.             return -code error "invalid option type \"$type\""
  320.         }
  321.  
  322.         if { ![string compare $type "Synonym"] } {
  323.             # test existence of synonym option
  324.             set syn [lindex $optdesc 1]
  325.             if { ![info exists classopt($syn)] } {
  326.                 return -code error "unknow option \"$syn\" for Synonym \"$option\""
  327.             }
  328.             set classopt($option) [list Synonym $syn]
  329.             continue
  330.         }
  331.  
  332.         # all other resource may have default value, readonly flag and
  333.         # optional arg depending on type
  334.         set value [lindex $optdesc 1]
  335.         set ro    [lindex $optdesc 2]
  336.         set arg   [lindex $optdesc 3]
  337.  
  338.         if { ![string compare $type "BwResource"] } {
  339.             # We don't keep BwResource. We simplify to type of sub BWidget
  340.             set subclass    [lindex $arg 0]
  341.             set realopt     [lindex $arg 1]
  342.             if { ![string length $realopt] } {
  343.                 set realopt $option
  344.             }
  345.  
  346.             upvar 0 ${subclass}::opt subclassopt
  347.             if { ![info exists subclassopt($realopt)] } {
  348.                 return -code error "unknow option \"$realopt\""
  349.             }
  350.             set suboptdesc $subclassopt($realopt)
  351.             if { $value == "" } {
  352.                 # We initialize default value
  353.                 set value [lindex $suboptdesc 1]
  354.             }
  355.             set type [lindex $suboptdesc 0]
  356.             set ro   [lindex $suboptdesc 2]
  357.             set arg  [lindex $suboptdesc 3]
  358.         set optionDbName ".[lindex [_configure_option $option ""] 0]"
  359.         option add *${class}${optionDbName} $value widgetDefault
  360.         set exports($option) $optionDbName
  361.             set classopt($option) [list $type $value $ro $arg]
  362.             continue
  363.         }
  364.  
  365.         # retreive default value for TkResource
  366.         if { ![string compare $type "TkResource"] } {
  367.             set tkwidget [lindex $arg 0]
  368.         set foo [$tkwidget ".ericFoo##"]
  369.             set realopt  [lindex $arg 1]
  370.             if { ![string length $realopt] } {
  371.                 set realopt $option
  372.             }
  373.             set tkoptions [_get_tkwidget_options $tkwidget]
  374.             if { ![string length $value] } {
  375.                 # We initialize default value
  376.         set ind [lsearch $tkoptions [list $realopt *]]
  377.                 set value [lindex [lindex $tkoptions $ind] end]
  378.             }
  379.         set optionDbName ".[lindex [_configure_option $option ""] 0]"
  380.         option add *${class}${optionDbName} $value widgetDefault
  381.         set exports($option) $optionDbName
  382.             set classopt($option) [list TkResource $value $ro \
  383.             [list $tkwidget $realopt]]
  384.         set optionClass($option) [lindex [$foo configure $realopt] 1]
  385.         ::destroy $foo
  386.             continue
  387.         }
  388.  
  389.     set optionDbName ".[lindex [_configure_option $option ""] 0]"
  390.     option add *${class}${optionDbName} $value widgetDefault
  391.     set exports($option) $optionDbName
  392.         # for any other resource type, we keep original optdesc
  393.         set classopt($option) [list $type $value $ro $arg]
  394.     }
  395. }
  396.  
  397.  
  398. # ------------------------------------------------------------------------------
  399. #  Command Widget::addmap
  400. # ------------------------------------------------------------------------------
  401. proc Widget::addmap { class subclass subpath options } {
  402.     upvar 0 ${class}::opt classopt
  403.     upvar 0 ${class}::optionExports exports
  404.     upvar 0 ${class}::optionClass optionClass
  405.     upvar 0 ${class}::map classmap
  406.     upvar 0 ${class}::map$subpath submap
  407.  
  408.     foreach {option realopt} $options {
  409.         if { ![string length $realopt] } {
  410.             set realopt $option
  411.         }
  412.     set val [lindex $classopt($option) 1]
  413.     set optDb ".[lindex [_configure_option $realopt ""] 0]"
  414.     if { ![string equal $subpath ":cmd"] } {
  415.         set optDb "$subpath$optDb"
  416.     }
  417.     option add *${class}${optDb} $val widgetDefault
  418.     lappend exports($option) $optDb
  419.     # Store the forward and backward mappings for this
  420.     # option <-> realoption pair
  421.         lappend classmap($option) $subpath $subclass $realopt
  422.     set submap($realopt) $option
  423.     }
  424. }
  425.  
  426.  
  427. # ------------------------------------------------------------------------------
  428. #  Command Widget::syncoptions
  429. # ------------------------------------------------------------------------------
  430. proc Widget::syncoptions { class subclass subpath options } {
  431.     upvar 0 ${class}::sync classync
  432.  
  433.     foreach {option realopt} $options {
  434.         if { ![string length $realopt] } {
  435.             set realopt $option
  436.         }
  437.         set classync($option) [list $subpath $subclass $realopt]
  438.     }
  439. }
  440.  
  441.  
  442. # ------------------------------------------------------------------------------
  443. #  Command Widget::init
  444. # ------------------------------------------------------------------------------
  445. proc Widget::init { class path options } {
  446.     upvar 0 ${class}::opt classopt
  447.     upvar 0 ${class}::$path:opt  pathopt
  448.     upvar 0 ${class}::$path:mod  pathmod
  449.     upvar 0 ${class}::map classmap
  450.     upvar 0 ${class}::$path:init pathinit
  451.  
  452.     if { [info exists pathopt] } {
  453.     unset pathopt
  454.     }
  455.     if { [info exists pathmod] } {
  456.     unset pathmod
  457.     }
  458.     # We prefer to use the actual widget for option db queries, but if it
  459.     # doesn't exist yet, do the next best thing:  create a widget of the
  460.     # same class and use that.
  461.     set fpath $path
  462.     set rdbclass [string map [list :: ""] $class]
  463.     if { ![winfo exists $path] } {
  464.     set fpath ".#BWidgetClass#$class"
  465.     if { ![winfo exists $fpath] } {
  466.         frame $fpath -class $rdbclass
  467.     }
  468.     }
  469.     foreach {option optdesc} [array get classopt] {
  470.         set pathmod($option) 0
  471.     if { [info exists classmap($option)] } {
  472.         continue
  473.     }
  474.         set type [lindex $optdesc 0]
  475.         if { ![string compare $type "Synonym"] } {
  476.         continue
  477.         }
  478.         if { ![string compare $type "TkResource"] } {
  479.             set alt [lindex [lindex $optdesc 3] 1]
  480.         } else {
  481.             set alt ""
  482.         }
  483.         set optdb [lindex [_configure_option $option $alt] 0]
  484.         set def   [option get $fpath $optdb $rdbclass]
  485.         if { [string length $def] } {
  486.             set pathopt($option) $def
  487.         } else {
  488.             set pathopt($option) [lindex $optdesc 1]
  489.         }
  490.     }
  491.  
  492.     set Widget::_class($path) $class
  493.     foreach {option value} $options {
  494.         if { ![info exists classopt($option)] } {
  495.             unset pathopt
  496.             unset pathmod
  497.             return -code error "unknown option \"$option\""
  498.         }
  499.         set optdesc $classopt($option)
  500.         set type    [lindex $optdesc 0]
  501.         if { ![string compare $type "Synonym"] } {
  502.             set option  [lindex $optdesc 1]
  503.             set optdesc $classopt($option)
  504.             set type    [lindex $optdesc 0]
  505.         }
  506.         set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
  507.     set pathinit($option) $pathopt($option)
  508.     }
  509. }
  510.  
  511. # Widget::parseArgs --
  512. #
  513. #    Given a widget class and a command-line spec, cannonize and validate
  514. #    the given options, and return a keyed list consisting of the 
  515. #    component widget and its masked portion of the command-line spec, and
  516. #    one extra entry consisting of the portion corresponding to the 
  517. #    megawidget itself.
  518. #
  519. # Arguments:
  520. #    class    widget class to parse for.
  521. #    options    command-line spec
  522. #
  523. # Results:
  524. #    result    keyed list of portions of the megawidget and that segment of
  525. #        the command line in which that portion is interested.
  526.  
  527. proc Widget::parseArgs {class options} {
  528.     upvar 0 ${class}::opt classopt
  529.     upvar 0 ${class}::map classmap
  530.     
  531.     foreach {option val} $options {
  532.     if { ![info exists classopt($option)] } {
  533.         error "unknown option \"$option\""
  534.     }
  535.         set optdesc $classopt($option)
  536.         set type    [lindex $optdesc 0]
  537.         if { ![string compare $type "Synonym"] } {
  538.             set option  [lindex $optdesc 1]
  539.             set optdesc $classopt($option)
  540.             set type    [lindex $optdesc 0]
  541.         }
  542.     if { ![string compare $type "TkResource"] } {
  543.         # Make sure that the widget used for this TkResource exists
  544.         Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0]
  545.     }
  546.     set val [$Widget::_optiontype($type) $option $val [lindex $optdesc 3]]
  547.         
  548.     if { [info exists classmap($option)] } {
  549.         foreach {subpath subclass realopt} $classmap($option) {
  550.         lappend maps($subpath) $realopt $val
  551.         }
  552.     } else {
  553.         lappend maps($class) $option $val
  554.     }
  555.     }
  556.     return [array get maps]
  557. }
  558.  
  559. # Widget::initFromODB --
  560. #
  561. #    Initialize a megawidgets options with information from the option
  562. #    database and from the command-line arguments given.
  563. #
  564. # Arguments:
  565. #    class    class of the widget.
  566. #    path    path of the widget -- should already exist.
  567. #    options    command-line arguments.
  568. #
  569. # Results:
  570. #    None.
  571.  
  572. proc Widget::initFromODB {class path options} {
  573.     upvar 0 ${class}::$path:opt  pathopt
  574.     upvar 0 ${class}::$path:mod  pathmod
  575.     upvar 0 ${class}::map classmap
  576.  
  577.     if { [info exists pathopt] } {
  578.     unset pathopt
  579.     }
  580.     if { [info exists pathmod] } {
  581.     unset pathmod
  582.     }
  583.     # We prefer to use the actual widget for option db queries, but if it
  584.     # doesn't exist yet, do the next best thing:  create a widget of the
  585.     # same class and use that.
  586.     set fpath [_get_window $class $path]
  587.     set rdbclass [string map [list :: ""] $class]
  588.     if { ![winfo exists $path] } {
  589.     set fpath ".#BWidgetClass#$class"
  590.     if { ![winfo exists $fpath] } {
  591.         frame $fpath -class $rdbclass
  592.     }
  593.     }
  594.     foreach {option optdesc} [array get ${class}::opt] {
  595.         set pathmod($option) 0
  596.     if { [info exists classmap($option)] } {
  597.         continue
  598.     }
  599.         set type [lindex $optdesc 0]
  600.         if { ![string compare $type "Synonym"] } {
  601.         continue
  602.         }
  603.     if { ![string compare $type "TkResource"] } {
  604.             set alt [lindex [lindex $optdesc 3] 1]
  605.         } else {
  606.             set alt ""
  607.         }
  608.         set optdb [lindex [_configure_option $option $alt] 0]
  609.         set def   [option get $fpath $optdb $rdbclass]
  610.         if { [string length $def] } {
  611.             set pathopt($option) $def
  612.         } else {
  613.             set pathopt($option) [lindex $optdesc 1]
  614.         }
  615.     }
  616.  
  617.     set Widget::_class($path) $class
  618.     array set pathopt $options
  619. }
  620.  
  621.  
  622.  
  623. # ------------------------------------------------------------------------------
  624. #  Command Widget::destroy
  625. # ------------------------------------------------------------------------------
  626. proc Widget::destroy { path } {
  627.     variable _class
  628.  
  629.     set class $_class($path)
  630.     upvar 0 ${class}::$path:opt pathopt
  631.     upvar 0 ${class}::$path:mod pathmod
  632.     upvar 0 ${class}::$path:init pathinit
  633.  
  634.     if {[info exists pathopt]} {
  635.         unset pathopt
  636.     }
  637.     if {[info exists pathmod]} {
  638.         unset pathmod
  639.     }
  640.     if {[info exists pathinit]} {
  641.         unset pathinit
  642.     }
  643. }
  644.  
  645.  
  646. # ------------------------------------------------------------------------------
  647. #  Command Widget::configure
  648. # ------------------------------------------------------------------------------
  649. proc Widget::configure { path options } {
  650.     set len [llength $options]
  651.     if { $len <= 1 } {
  652.         return [_get_configure $path $options]
  653.     } elseif { $len % 2 == 1 } {
  654.         return -code error "incorrect number of arguments"
  655.     }
  656.  
  657.     variable _class
  658.     variable _optiontype
  659.  
  660.     set class $_class($path)
  661.     upvar 0 ${class}::opt  classopt
  662.     upvar 0 ${class}::map  classmap
  663.     upvar 0 ${class}::$path:opt pathopt
  664.     upvar 0 ${class}::$path:mod pathmod
  665.  
  666.     set window [_get_window $class $path]
  667.     foreach {option value} $options {
  668.         if { ![info exists classopt($option)] } {
  669.             return -code error "unknown option \"$option\""
  670.         }
  671.         set optdesc $classopt($option)
  672.         set type    [lindex $optdesc 0]
  673.         if { ![string compare $type "Synonym"] } {
  674.             set option  [lindex $optdesc 1]
  675.             set optdesc $classopt($option)
  676.             set type    [lindex $optdesc 0]
  677.         }
  678.         if { ![lindex $optdesc 2] } {
  679.             set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
  680.             if { [info exists classmap($option)] } {
  681.         set window [_get_window $class $window]
  682.                 foreach {subpath subclass realopt} $classmap($option) {
  683.                     if { [string length $subclass] } {
  684.             set curval [${subclass}::cget $window$subpath $realopt]
  685.                         ${subclass}::configure $window$subpath $realopt $newval
  686.                     } else {
  687.             set curval [$window$subpath cget $realopt]
  688.                         $window$subpath configure $realopt $newval
  689.                     }
  690.                 }
  691.             } else {
  692.         set curval $pathopt($option)
  693.         set pathopt($option) $newval
  694.         }
  695.         set pathmod($option) [expr {![string equal $newval $curval]}]
  696.         }
  697.     }
  698.  
  699.     return {}
  700. }
  701.  
  702.  
  703. # ------------------------------------------------------------------------------
  704. #  Command Widget::cget
  705. # ------------------------------------------------------------------------------
  706. proc Widget::cget { path option } {
  707.     if { ![info exists ::Widget::_class($path)] } {
  708.         return -code error "unknown widget $path"
  709.     }
  710.  
  711.     set class $::Widget::_class($path)
  712.     if { ![info exists ${class}::opt($option)] } {
  713.         return -code error "unknown option \"$option\""
  714.     }
  715.  
  716.     set optdesc [set ${class}::opt($option)]
  717.     set type    [lindex $optdesc 0]
  718.     if { ![string compare $type "Synonym"] } {
  719.         set option [lindex $optdesc 1]
  720.     }
  721.  
  722.     if { [info exists ${class}::map($option)] } {
  723.     foreach {subpath subclass realopt} [set ${class}::map($option)] {break}
  724.     set path "[_get_window $class $path]$subpath"
  725.     return [$path cget $realopt]
  726.     }
  727.     upvar 0 ${class}::$path:opt pathopt
  728.     set pathopt($option)
  729. }
  730.  
  731.  
  732. # ------------------------------------------------------------------------------
  733. #  Command Widget::subcget
  734. # ------------------------------------------------------------------------------
  735. proc Widget::subcget { path subwidget } {
  736.     set class $::Widget::_class($path)
  737.     upvar 0 ${class}::$path:opt pathopt
  738.     upvar 0 ${class}::map$subwidget submap
  739.     upvar 0 ${class}::$path:init pathinit
  740.  
  741.     set result {}
  742.     foreach realopt [array names submap] {
  743.     if { [info exists pathinit($submap($realopt))] } {
  744.         lappend result $realopt $pathopt($submap($realopt))
  745.     }
  746.     }
  747.     return $result
  748. }
  749.  
  750.  
  751. # ------------------------------------------------------------------------------
  752. #  Command Widget::hasChanged
  753. # ------------------------------------------------------------------------------
  754. proc Widget::hasChanged { path option pvalue } {
  755.     upvar    $pvalue value
  756.     set class $::Widget::_class($path)
  757.     upvar 0 ${class}::$path:mod pathmod
  758.  
  759.     set value   [Widget::cget $path $option]
  760.     set result  $pathmod($option)
  761.     set pathmod($option) 0
  762.  
  763.     return $result
  764. }
  765.  
  766. proc Widget::hasChangedX { path option args } {
  767.     set class $::Widget::_class($path)
  768.     upvar 0 ${class}::$path:mod pathmod
  769.  
  770.     set result  $pathmod($option)
  771.     set pathmod($option) 0
  772.     foreach option $args {
  773.     lappend result $pathmod($option)
  774.     set pathmod($option) 0
  775.     }
  776.  
  777.     set result
  778. }
  779.  
  780.  
  781. # ------------------------------------------------------------------------------
  782. #  Command Widget::setoption
  783. # ------------------------------------------------------------------------------
  784. proc Widget::setoption { path option value } {
  785. #    variable _class
  786.  
  787. #    set class $_class($path)
  788. #    upvar 0 ${class}::$path:opt pathopt
  789.  
  790. #    set pathopt($option) $value
  791.     Widget::configure $path [list $option $value]
  792. }
  793.  
  794.  
  795. # ------------------------------------------------------------------------------
  796. #  Command Widget::getoption
  797. # ------------------------------------------------------------------------------
  798. proc Widget::getoption { path option } {
  799. #    set class $::Widget::_class($path)
  800. #    upvar 0 ${class}::$path:opt pathopt
  801.  
  802. #    return $pathopt($option)
  803.     return [Widget::cget $path $option]
  804. }
  805.  
  806. # Widget::getMegawidgetOption --
  807. #
  808. #    Bypass the superfluous checks in cget and just directly peer at the
  809. #    widget's data space.  This is much more fragile than cget, so it 
  810. #    should only be used with great care, in places where speed is critical.
  811. #
  812. # Arguments:
  813. #    path    widget to lookup options for.
  814. #    option    option to retrieve.
  815. #
  816. # Results:
  817. #    value    option value.
  818.  
  819. proc Widget::getMegawidgetOption {path option} {
  820.     set class $::Widget::_class($path)
  821.     upvar 0 ${class}::${path}:opt pathopt
  822.     set pathopt($option)
  823. }
  824.  
  825. # Widget::setMegawidgetOption --
  826. #
  827. #    Bypass the superfluous checks in cget and just directly poke at the
  828. #    widget's data space.  This is much more fragile than configure, so it 
  829. #    should only be used with great care, in places where speed is critical.
  830. #
  831. # Arguments:
  832. #    path    widget to lookup options for.
  833. #    option    option to retrieve.
  834. #    value    option value.
  835. #
  836. # Results:
  837. #    value    option value.
  838.  
  839. proc Widget::setMegawidgetOption {path option value} {
  840.     set class $::Widget::_class($path)
  841.     upvar 0 ${class}::${path}:opt pathopt
  842.     set pathopt($option) $value
  843. }
  844.  
  845. # ------------------------------------------------------------------------------
  846. #  Command Widget::_get_window
  847. #  returns the window corresponding to widget path
  848. # ------------------------------------------------------------------------------
  849. proc Widget::_get_window { class path } {
  850.     set idx [string last "#" $path]
  851.     if { $idx != -1 && ![string compare [string range $path [expr {$idx+1}] end] $class] } {
  852.         return [string range $path 0 [expr {$idx-1}]]
  853.     } else {
  854.         return $path
  855.     }
  856. }
  857.  
  858.  
  859. # ------------------------------------------------------------------------------
  860. #  Command Widget::_get_configure
  861. #  returns the configuration list of options
  862. #  (as tk widget do - [$w configure ?option?])
  863. # ------------------------------------------------------------------------------
  864. proc Widget::_get_configure { path options } {
  865.     variable _class
  866.  
  867.     set class $_class($path)
  868.     upvar 0 ${class}::opt classopt
  869.     upvar 0 ${class}::map classmap
  870.     upvar 0 ${class}::$path:opt pathopt
  871.     upvar 0 ${class}::$path:mod pathmod
  872.  
  873.     set len [llength $options]
  874.     if { !$len } {
  875.         set result {}
  876.         foreach option [lsort [array names classopt]] {
  877.             set optdesc $classopt($option)
  878.             set type    [lindex $optdesc 0]
  879.             if { ![string compare $type "Synonym"] } {
  880.                 set syn     $option
  881.                 set option  [lindex $optdesc 1]
  882.                 set optdesc $classopt($option)
  883.                 set type    [lindex $optdesc 0]
  884.             } else {
  885.                 set syn ""
  886.             }
  887.             if { ![string compare $type "TkResource"] } {
  888.                 set alt [lindex [lindex $optdesc 3] 1]
  889.             } else {
  890.                 set alt ""
  891.             }
  892.             set res [_configure_option $option $alt]
  893.             if { $syn == "" } {
  894.                 lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
  895.             } else {
  896.                 lappend result [list $syn [lindex $res 0]]
  897.             }
  898.         }
  899.         return $result
  900.     } elseif { $len == 1 } {
  901.         set option  [lindex $options 0]
  902.         if { ![info exists classopt($option)] } {
  903.             return -code error "unknown option \"$option\""
  904.         }
  905.         set optdesc $classopt($option)
  906.         set type    [lindex $optdesc 0]
  907.         if { ![string compare $type "Synonym"] } {
  908.             set option  [lindex $optdesc 1]
  909.             set optdesc $classopt($option)
  910.             set type    [lindex $optdesc 0]
  911.         }
  912.         if { ![string compare $type "TkResource"] } {
  913.             set alt [lindex [lindex $optdesc 3] 1]
  914.         } else {
  915.             set alt ""
  916.         }
  917.         set res [_configure_option $option $alt]
  918.         return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
  919.     }
  920. }
  921.  
  922.  
  923. # ------------------------------------------------------------------------------
  924. #  Command Widget::_configure_option
  925. # ------------------------------------------------------------------------------
  926. proc Widget::_configure_option { option altopt } {
  927.     variable _optiondb
  928.     variable _optionclass
  929.  
  930.     if { [info exists _optiondb($option)] } {
  931.         set optdb $_optiondb($option)
  932.     } else {
  933.         set optdb [string range $option 1 end]
  934.     }
  935.     if { [info exists _optionclass($option)] } {
  936.         set optclass $_optionclass($option)
  937.     } elseif { [string length $altopt] } {
  938.         if { [info exists _optionclass($altopt)] } {
  939.             set optclass $_optionclass($altopt)
  940.         } else {
  941.             set optclass [string range $altopt 1 end]
  942.         }
  943.     } else {
  944.         set optclass [string range $option 1 end]
  945.     }
  946.     return [list $optdb $optclass]
  947. }
  948.  
  949.  
  950. # ------------------------------------------------------------------------------
  951. #  Command Widget::_get_tkwidget_options
  952. # ------------------------------------------------------------------------------
  953. proc Widget::_get_tkwidget_options { tkwidget } {
  954.     variable _tk_widget
  955.     variable _optiondb
  956.     variable _optionclass
  957.     
  958.     set widget ".#BWidget#$tkwidget"
  959.     if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } {
  960.         set widget [$tkwidget $widget]
  961.         set config [$widget configure]
  962.         foreach optlist $config {
  963.             set opt [lindex $optlist 0]
  964.             if { [llength $optlist] == 2 } {
  965.                 set refsyn [lindex $optlist 1]
  966.                 # search for class
  967.                 set idx [lsearch $config [list * $refsyn *]]
  968.                 if { $idx == -1 } {
  969.                     if { [string index $refsyn 0] == "-" } {
  970.                         # search for option (tk8.1b1 bug)
  971.                         set idx [lsearch $config [list $refsyn * *]]
  972.                     } else {
  973.                         # last resort
  974.                         set idx [lsearch $config [list -[string tolower $refsyn] * *]]
  975.                     }
  976.                     if { $idx == -1 } {
  977.                         # fed up with "can't read classopt()"
  978.                         return -code error "can't find option of synonym $opt"
  979.                     }
  980.                 }
  981.                 set syn [lindex [lindex $config $idx] 0]
  982.                 set def [lindex [lindex $config $idx] 3]
  983.                 lappend _tk_widget($tkwidget) [list $opt $syn $def]
  984.             } else {
  985.                 set def [lindex $optlist 3]
  986.                 lappend _tk_widget($tkwidget) [list $opt $def]
  987.                 set _optiondb($opt)    [lindex $optlist 1]
  988.                 set _optionclass($opt) [lindex $optlist 2]
  989.             }
  990.         }
  991.     }
  992.     return $_tk_widget($tkwidget)
  993. }
  994.  
  995.  
  996. # ------------------------------------------------------------------------------
  997. #  Command Widget::_test_tkresource
  998. # ------------------------------------------------------------------------------
  999. proc Widget::_test_tkresource { option value arg } {
  1000. #    set tkwidget [lindex $arg 0]
  1001. #    set realopt  [lindex $arg 1]
  1002.     foreach {tkwidget realopt} $arg break
  1003.     set path     ".#BWidget#$tkwidget"
  1004.     set old      [$path cget $realopt]
  1005.     $path configure $realopt $value
  1006.     set res      [$path cget $realopt]
  1007.     $path configure $realopt $old
  1008.  
  1009.     return $res
  1010. }
  1011.  
  1012.  
  1013. # ------------------------------------------------------------------------------
  1014. #  Command Widget::_test_bwresource
  1015. # ------------------------------------------------------------------------------
  1016. proc Widget::_test_bwresource { option value arg } {
  1017.     return -code error "bad option type BwResource in widget"
  1018. }
  1019.  
  1020.  
  1021. # ------------------------------------------------------------------------------
  1022. #  Command Widget::_test_synonym
  1023. # ------------------------------------------------------------------------------
  1024. proc Widget::_test_synonym { option value arg } {
  1025.     return -code error "bad option type Synonym in widget"
  1026. }
  1027.  
  1028.  
  1029. # ------------------------------------------------------------------------------
  1030. #  Command Widget::_test_string
  1031. # ------------------------------------------------------------------------------
  1032. proc Widget::_test_string { option value arg } {
  1033.     set value
  1034. }
  1035.  
  1036.  
  1037. # ------------------------------------------------------------------------------
  1038. #  Command Widget::_test_flag
  1039. # ------------------------------------------------------------------------------
  1040. proc Widget::_test_flag { option value arg } {
  1041.     set len [string length $value]
  1042.     set res ""
  1043.     for {set i 0} {$i < $len} {incr i} {
  1044.         set c [string index $value $i]
  1045.         if { [string first $c $arg] == -1 } {
  1046.             return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
  1047.         }
  1048.         if { [string first $c $res] == -1 } {
  1049.             append res $c
  1050.         }
  1051.     }
  1052.     return $res
  1053. }
  1054.  
  1055.  
  1056. # -----------------------------------------------------------------------------
  1057. #  Command Widget::_test_enum
  1058. # -----------------------------------------------------------------------------
  1059. proc Widget::_test_enum { option value arg } {
  1060.     if { [lsearch $arg $value] == -1 } {
  1061.         set last [lindex   $arg end]
  1062.         set sub  [lreplace $arg end end]
  1063.         if { [llength $sub] } {
  1064.             set str "[join $sub ", "] or $last"
  1065.         } else {
  1066.             set str $last
  1067.         }
  1068.         return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
  1069.     }
  1070.     return $value
  1071. }
  1072.  
  1073.  
  1074. # -----------------------------------------------------------------------------
  1075. #  Command Widget::_test_int
  1076. # -----------------------------------------------------------------------------
  1077. proc Widget::_test_int { option value arg } {
  1078.     if { ![string is int -strict $value] || \
  1079.         ([string length $arg] && \
  1080.         ![expr [string map [list %d $value] $arg]]) } {
  1081.             return -code error "bad $option value\
  1082.                 \"$value\": must be integer ($arg)"
  1083.     }
  1084.     return $value
  1085. }
  1086.  
  1087.  
  1088. # -----------------------------------------------------------------------------
  1089. #  Command Widget::_test_boolean
  1090. # -----------------------------------------------------------------------------
  1091. proc Widget::_test_boolean { option value arg } {
  1092.     if { ![string is boolean -strict $value] } {
  1093.         return -code error "bad $option value \"$value\": must be boolean"
  1094.     }
  1095.  
  1096.     # Get the canonical form of the boolean value (1 for true, 0 for false)
  1097.     return [string is true $value]
  1098. }
  1099.  
  1100.  
  1101. # -----------------------------------------------------------------------------
  1102. #  Command Widget::focusNext
  1103. #  Same as tk_focusNext, but call Widget::focusOK
  1104. # -----------------------------------------------------------------------------
  1105. proc Widget::focusNext { w } {
  1106.     set cur $w
  1107.     while 1 {
  1108.  
  1109.     # Descend to just before the first child of the current widget.
  1110.  
  1111.     set parent $cur
  1112.     set children [winfo children $cur]
  1113.     set i -1
  1114.  
  1115.     # Look for the next sibling that isn't a top-level.
  1116.  
  1117.     while 1 {
  1118.         incr i
  1119.         if {$i < [llength $children]} {
  1120.         set cur [lindex $children $i]
  1121.         if {[winfo toplevel $cur] == $cur} {
  1122.             continue
  1123.         } else {
  1124.             break
  1125.         }
  1126.         }
  1127.  
  1128.         # No more siblings, so go to the current widget's parent.
  1129.         # If it's a top-level, break out of the loop, otherwise
  1130.         # look for its next sibling.
  1131.  
  1132.         set cur $parent
  1133.         if {[winfo toplevel $cur] == $cur} {
  1134.         break
  1135.         }
  1136.         set parent [winfo parent $parent]
  1137.         set children [winfo children $parent]
  1138.         set i [lsearch -exact $children $cur]
  1139.     }
  1140.     if {($cur == $w) || [focusOK $cur]} {
  1141.         return $cur
  1142.     }
  1143.     }
  1144. }
  1145.  
  1146.  
  1147. # -----------------------------------------------------------------------------
  1148. #  Command Widget::focusPrev
  1149. #  Same as tk_focusPrev, but call Widget::focusOK
  1150. # -----------------------------------------------------------------------------
  1151. proc Widget::focusPrev { w } {
  1152.     set cur $w
  1153.     while 1 {
  1154.  
  1155.     # Collect information about the current window's position
  1156.     # among its siblings.  Also, if the window is a top-level,
  1157.     # then reposition to just after the last child of the window.
  1158.     
  1159.     if {[winfo toplevel $cur] == $cur}  {
  1160.         set parent $cur
  1161.         set children [winfo children $cur]
  1162.         set i [llength $children]
  1163.     } else {
  1164.         set parent [winfo parent $cur]
  1165.         set children [winfo children $parent]
  1166.         set i [lsearch -exact $children $cur]
  1167.     }
  1168.  
  1169.     # Go to the previous sibling, then descend to its last descendant
  1170.     # (highest in stacking order.  While doing this, ignore top-levels
  1171.     # and their descendants.  When we run out of descendants, go up
  1172.     # one level to the parent.
  1173.  
  1174.     while {$i > 0} {
  1175.         incr i -1
  1176.         set cur [lindex $children $i]
  1177.         if {[winfo toplevel $cur] == $cur} {
  1178.         continue
  1179.         }
  1180.         set parent $cur
  1181.         set children [winfo children $parent]
  1182.         set i [llength $children]
  1183.     }
  1184.     set cur $parent
  1185.     if {($cur == $w) || [focusOK $cur]} {
  1186.         return $cur
  1187.     }
  1188.     }
  1189. }
  1190.  
  1191.  
  1192. # ------------------------------------------------------------------------------
  1193. #  Command Widget::focusOK
  1194. #  Same as tk_focusOK, but handles -editable option and whole tags list.
  1195. # ------------------------------------------------------------------------------
  1196. proc Widget::focusOK { w } {
  1197.     set code [catch {$w cget -takefocus} value]
  1198.     if { $code == 1 } {
  1199.         return 0
  1200.     }
  1201.     if {($code == 0) && ($value != "")} {
  1202.     if {$value == 0} {
  1203.         return 0
  1204.     } elseif {$value == 1} {
  1205.         return [winfo viewable $w]
  1206.     } else {
  1207.         set value [uplevel \#0 $value $w]
  1208.             if {$value != ""} {
  1209.         return $value
  1210.         }
  1211.         }
  1212.     }
  1213.     if {![winfo viewable $w]} {
  1214.     return 0
  1215.     }
  1216.     set code [catch {$w cget -state} value]
  1217.     if {($code == 0) && ($value == "disabled")} {
  1218.     return 0
  1219.     }
  1220.     set code [catch {$w cget -editable} value]
  1221.     if {($code == 0) && !$value} {
  1222.         return 0
  1223.     }
  1224.  
  1225.     set top [winfo toplevel $w]
  1226.     foreach tags [bindtags $w] {
  1227.         if { [string compare $tags $top]  &&
  1228.              [string compare $tags "all"] &&
  1229.              [regexp Key [bind $tags]] } {
  1230.             return 1
  1231.         }
  1232.     }
  1233.     return 0
  1234. }
  1235.  
  1236. # Widget::varForOption --
  1237. #
  1238. #    Retrieve a fully qualified variable name for the option specified.
  1239. #    If the option is not one for which a variable exists, throw an error 
  1240. #    (ie, those options that map directly to widget options).
  1241. #
  1242. # Arguments:
  1243. #    path    megawidget to get an option var for.
  1244. #    option    option to get a var for.
  1245. #
  1246. # Results:
  1247. #    varname    name of the variable, fully qualified, suitable for tracing.
  1248.  
  1249. proc Widget::varForOption {path option} {
  1250.     variable _class
  1251.     variable _optiontype
  1252.  
  1253.     set class $_class($path)
  1254.     upvar 0 ${class}::$path:opt pathopt
  1255.  
  1256.     if { ![info exists pathopt($option)] } {
  1257.     error "unable to find variable for option \"$option\""
  1258.     }
  1259.     set varname "::Widget::${class}::$path:opt($option)"
  1260.     return $varname
  1261. }
  1262.  
  1263.