source: trunk/BWidget-1.2.1/widget.tcl

Last change on this file was 931, checked in by toby, 11 years ago

include rest of files

File size: 31.9 KB
Line 
1# ------------------------------------------------------------------------------
2#  widget.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: widget.tcl,v 1.12 1999/05/20 15:45:43 eric 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
29namespace 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# ------------------------------------------------------------------------------
58proc 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# ------------------------------------------------------------------------------
148proc 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# ------------------------------------------------------------------------------
234proc 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# ------------------------------------------------------------------------------
315proc 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# ------------------------------------------------------------------------------
330proc 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# ------------------------------------------------------------------------------
345proc 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# ------------------------------------------------------------------------------
405proc 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# ------------------------------------------------------------------------------
420proc 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# ------------------------------------------------------------------------------
473proc 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# ------------------------------------------------------------------------------
512proc 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# ------------------------------------------------------------------------------
534proc 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# ------------------------------------------------------------------------------
553proc 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# ------------------------------------------------------------------------------
566proc 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# ------------------------------------------------------------------------------
580proc 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# ------------------------------------------------------------------------------
595proc 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# ------------------------------------------------------------------------------
657proc 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# ------------------------------------------------------------------------------
684proc 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# ------------------------------------------------------------------------------
729proc 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# ------------------------------------------------------------------------------
745proc 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# ------------------------------------------------------------------------------
753proc 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# ------------------------------------------------------------------------------
761proc Widget::_test_string { option value arg } {
762    return $value
763}
764
765
766# ------------------------------------------------------------------------------
767#  Command Widget::_test_flag
768# ------------------------------------------------------------------------------
769proc 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# ------------------------------------------------------------------------------
788proc 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# ------------------------------------------------------------------------------
806proc 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# ------------------------------------------------------------------------------
823proc 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# ------------------------------------------------------------------------------
843proc 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# ------------------------------------------------------------------------------
889proc 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# ------------------------------------------------------------------------------
934proc 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}
Note: See TracBrowser for help on using the repository browser.