1# ----------------------------------------------------------------------------
2#  progressbar.tcl
3#  This file is part of Unifix BWidget Toolkit
4# ----------------------------------------------------------------------------
5#  Index of commands:
6#     - ProgressBar::create
7#     - ProgressBar::configure
8#     - ProgressBar::cget
9#     - ProgressBar::_destroy
10#     - ProgressBar::_modify
11# ----------------------------------------------------------------------------
12
13package provide PBar 1.0
14
15# ----------------------------------------------------------------------------
16#  utils.tcl
17#  This file is part of Unifix BWidget Toolkit
18#  $Id: utils.tcl,v 1.12 2004/09/24 23:57:13 hobbs Exp $
19# ----------------------------------------------------------------------------
20#  Index of commands:
21#     - GlobalVar::exists
22#     - GlobalVar::setvarvar
23#     - GlobalVar::getvarvar
24#     - BWidget::assert
25#     - BWidget::clonename
26#     - BWidget::get3dcolor
27#     - BWidget::XLFDfont
28#     - BWidget::place
29#     - BWidget::grab
30#     - BWidget::focus
31# ----------------------------------------------------------------------------
32
33namespace eval GlobalVar {
34    proc use {} {}
35}
36
37
38namespace eval BWidget {
39    variable _top
40    variable _gstack {}
41    variable _fstack {}
42    proc use {} {}
43}
44
45
46# ----------------------------------------------------------------------------
47#  Command GlobalVar::exists
48# ----------------------------------------------------------------------------
49proc GlobalVar::exists { varName } {
50    return [uplevel \#0 [list info exists $varName]]
51}
52
53
54# ----------------------------------------------------------------------------
55#  Command GlobalVar::setvar
56# ----------------------------------------------------------------------------
57proc GlobalVar::setvar { varName value } {
58    return [uplevel \#0 [list set $varName $value]]
59}
60
61
62# ----------------------------------------------------------------------------
63#  Command GlobalVar::getvar
64# ----------------------------------------------------------------------------
65proc GlobalVar::getvar { varName } {
66    return [uplevel \#0 [list set $varName]]
67}
68
69
70# ----------------------------------------------------------------------------
71#  Command GlobalVar::tracevar
72# ----------------------------------------------------------------------------
73proc GlobalVar::tracevar { cmd varName args } {
74    return [uplevel \#0 [list trace $cmd $varName] $args]
75}
76
77
78
79# ----------------------------------------------------------------------------
80#  Command BWidget::lreorder
81# ----------------------------------------------------------------------------
82proc BWidget::lreorder { list neworder } {
83    set pos     0
84    set newlist {}
85    foreach e $neworder {
86        if { [lsearch -exact $list $e] != -1 } {
87            lappend newlist $e
88            set tabelt($e)  1
89        }
90    }
91    set len [llength $newlist]
92    if { !$len } {
93        return $list
94    }
95    if { $len == [llength $list] } {
96        return $newlist
97    }
98    set pos 0
99    foreach e $list {
100        if { ![info exists tabelt($e)] } {
101            set newlist [linsert $newlist $pos $e]
102        }
103        incr pos
104    }
105    return $newlist
106}
107
108
109# ----------------------------------------------------------------------------
110#  Command BWidget::assert
111# ----------------------------------------------------------------------------
112proc BWidget::assert { exp {msg ""}} {
113    set res [uplevel 1 expr $exp]
114    if { !$res} {
115        if { $msg == "" } {
116            return -code error "Assertion failed: {$exp}"
117        } else {
118            return -code error $msg
119        }
120    }
121}
122
123
124# ----------------------------------------------------------------------------
125#  Command BWidget::clonename
126# ----------------------------------------------------------------------------
127proc BWidget::clonename { menu } {
128    set path     ""
129    set menupath ""
130    set found    0
131    foreach widget [lrange [split $menu "."] 1 end] {
132        if { $found || [winfo class "$path.$widget"] == "Menu" } {
133            set found 1
134            append menupath "#" $widget
135            append path "." $menupath
136        } else {
137            append menupath "#" $widget
138            append path "." $widget
139        }
140    }
141    return $path
142}
143
144
145# ----------------------------------------------------------------------------
146#  Command BWidget::getname
147# ----------------------------------------------------------------------------
148proc BWidget::getname { name } {
149    if { [string length $name] } {
150        set text [option get . "${name}Name" ""]
151        if { [string length $text] } {
152            return [parsetext $text]
153        }
154    }
155    return {}
156 }
157
158
159# ----------------------------------------------------------------------------
160#  Command BWidget::parsetext
161# ----------------------------------------------------------------------------
162proc BWidget::parsetext { text } {
163    set result ""
164    set index  -1
165    set start  0
166    while { [string length $text] } {
167        set idx [string first "&" $text]
168        if { $idx == -1 } {
169            append result $text
170            set text ""
171        } else {
172            set char [string index $text [expr {$idx+1}]]
173            if { $char == "&" } {
174                append result [string range $text 0 $idx]
175                set    text   [string range $text [expr {$idx+2}] end]
176                set    start  [expr {$start+$idx+1}]
177            } else {
178                append result [string range $text 0 [expr {$idx-1}]]
179                set    text   [string range $text [expr {$idx+1}] end]
180                incr   start  $idx
181                set    index  $start
182            }
183        }
184    }
185    return [list $result $index]
186}
187
188
189# ----------------------------------------------------------------------------
190#  Command BWidget::get3dcolor
191# ----------------------------------------------------------------------------
192proc BWidget::get3dcolor { path bgcolor } {
193    foreach val [winfo rgb $path $bgcolor] {
194        lappend dark [expr {60*$val/100}]
195        set tmp1 [expr {14*$val/10}]
196        if { $tmp1 > 65535 } {
197            set tmp1 65535
198        }
199        set tmp2 [expr {(65535+$val)/2}]
200        lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}]
201    }
202    return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
203}
204
205
206# ----------------------------------------------------------------------------
207#  Command BWidget::XLFDfont
208# ----------------------------------------------------------------------------
209proc BWidget::XLFDfont { cmd args } {
210    switch -- $cmd {
211        create {
212            set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
213        }
214        configure {
215            set font [lindex $args 0]
216            set args [lrange $args 1 end]
217        }
218        default {
219            return -code error "XLFDfont: commande incorrect: $cmd"
220        }
221    }
222    set lfont [split $font "-"]
223    if { [llength $lfont] != 15 } {
224        return -code error "XLFDfont: description XLFD incorrect: $font"
225    }
226
227    foreach {option value} $args {
228        switch -- $option {
229            -foundry { set index 1 }
230            -family  { set index 2 }
231            -weight  { set index 3 }
232            -slant   { set index 4 }
233            -size    { set index 7 }
234            default  { return -code error "XLFDfont: option incorrecte: $option" }
235        }
236        set lfont [lreplace $lfont $index $index $value]
237    }
238    return [join $lfont "-"]
239}
240
241
242
243# ----------------------------------------------------------------------------
244#  Command BWidget::place
245# ----------------------------------------------------------------------------
246#
247# Notes:
248#  For Windows systems with more than one monitor the available screen area may
249#  have negative positions. Geometry settings with negative numbers are used
250#  under X to place wrt the right or bottom of the screen. On windows, Tk
251#  continues to do this. However, a geometry such as 100x100+-200-100 can be
252#  used to place a window onto a secondary monitor. Passing the + gets Tk
253#  to pass the remainder unchanged so the Windows manager then handles -200
254#  which is a position on the left hand monitor.
255#  I've tested this for left, right, above and below the primary monitor.
256#  Currently there is no way to ask Tk the extent of the Windows desktop in
257#  a multi monitor system. Nor what the legal co-ordinate range might be.
258#
259proc BWidget::place { path w h args } {
260    variable _top
261
262    update idletasks
263    set reqw [winfo reqwidth  $path]
264    set reqh [winfo reqheight $path]
265    if { $w == 0 } {set w $reqw}
266    if { $h == 0 } {set h $reqh}
267
268    set arglen [llength $args]
269    if { $arglen > 3 } {
270        return -code error "BWidget::place: bad number of argument"
271    }
272
273    if { $arglen > 0 } {
274        set where [lindex $args 0]
275	set list  [list "at" "center" "left" "right" "above" "below"]
276        set idx   [lsearch $list $where]
277        if { $idx == -1 } {
278	    return -code error [BWidget::badOptionString position $where $list]
279        }
280        if { $idx == 0 } {
281            set err [catch {
282                # purposely removed the {} around these expressions - [PT]
283                set x [expr int([lindex $args 1])]
284                set y [expr int([lindex $args 2])]
285            }]
286            if { $err } {
287                return -code error "BWidget::place: incorrect position"
288            }
289            if {$::tcl_platform(platform) == "windows"} {
290                # handle windows multi-screen. -100 != +-100
291                if {[string index [lindex $args 1] 0] != "-"} {
292                    set x "+$x"
293                }
294                if {[string index [lindex $args 2] 0] != "-"} {
295                    set y "+$y"
296                }
297            } else {
298                if { $x >= 0 } {
299                    set x "+$x"
300                }
301                if { $y >= 0 } {
302                    set y "+$y"
303                }
304            }
305        } else {
306            if { $arglen == 2 } {
307                set widget [lindex $args 1]
308                if { ![winfo exists $widget] } {
309                    return -code error "BWidget::place: \"$widget\" does not exist"
310                }
311	    } else {
312		set widget .
313	    }
314            set sw [winfo screenwidth  $path]
315            set sh [winfo screenheight $path]
316            if { $idx == 1 } {
317                if { $arglen == 2 } {
318                    # center to widget
319                    set x0 [expr {[winfo rootx $widget] + ([winfo width  $widget] - $w)/2}]
320                    set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}]
321                } else {
322                    # center to screen
323                    set x0 [expr {([winfo screenwidth  $path] - $w)/2 - [winfo vrootx $path]}]
324                    set y0 [expr {([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]}]
325                }
326                set x "+$x0"
327                set y "+$y0"
328                if {$::tcl_platform(platform) != "windows"} {
329                    if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
330                    if { $x0 < 0 }      {set x "+0"}
331                    if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
332                    if { $y0 < 0 }      {set y "+0"}
333                }
334            } else {
335                set x0 [winfo rootx $widget]
336                set y0 [winfo rooty $widget]
337                set x1 [expr {$x0 + [winfo width  $widget]}]
338                set y1 [expr {$y0 + [winfo height $widget]}]
339                if { $idx == 2 || $idx == 3 } {
340                    set y "+$y0"
341                    if {$::tcl_platform(platform) != "windows"} {
342                        if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
343                        if { $y0 < 0 }      {set y "+0"}
344                    }
345                    if { $idx == 2 } {
346                        # try left, then right if out, then 0 if out
347                        if { $x0 >= $w } {
348                            set x [expr {$x0-$sw}]
349                        } elseif { $x1+$w <= $sw } {
350                            set x "+$x1"
351                        } else {
352                            set x "+0"
353                        }
354                    } else {
355                        # try right, then left if out, then 0 if out
356                        if { $x1+$w <= $sw } {
357                            set x "+$x1"
358                        } elseif { $x0 >= $w } {
359                            set x [expr {$x0-$sw}]
360                        } else {
361                            set x "-0"
362                        }
363                    }
364                } else {
365                    set x "+$x0"
366                    if {$::tcl_platform(platform) != "windows"} {
367                        if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
368                        if { $x0 < 0 }      {set x "+0"}
369                    }
370                    if { $idx == 4 } {
371                        # try top, then bottom, then 0
372                        if { $h <= $y0 } {
373                            set y [expr {$y0-$sh}]
374                        } elseif { $y1+$h <= $sh } {
375                            set y "+$y1"
376                        } else {
377                            set y "+0"
378                        }
379                    } else {
380                        # try bottom, then top, then 0
381                        if { $y1+$h <= $sh } {
382                            set y "+$y1"
383                        } elseif { $h <= $y0 } {
384                            set y [expr {$y0-$sh}]
385                        } else {
386                            set y "-0"
387                        }
388                    }
389                }
390            }
391        }
392
393        ## If there's not a + or - in front of the number, we need to add one.
394        if {[string is integer [string index $x 0]]} { set x +$x }
395        if {[string is integer [string index $y 0]]} { set y +$y }
396
397        wm geometry $path "${w}x${h}${x}${y}"
398    } else {
399        wm geometry $path "${w}x${h}"
400    }
401    update idletasks
402}
403
404
405# ----------------------------------------------------------------------------
406#  Command BWidget::grab
407# ----------------------------------------------------------------------------
408proc BWidget::grab { option path } {
409    variable _gstack
410
411    if { $option == "release" } {
412        catch {::grab release $path}
413        while { [llength $_gstack] } {
414            set grinfo  [lindex $_gstack end]
415            set _gstack [lreplace $_gstack end end]
416            foreach {oldg mode} $grinfo {
417                if { ![string equal $oldg $path] && [winfo exists $oldg] } {
418                    if { $mode == "global" } {
419                        catch {::grab -global $oldg}
420                    } else {
421                        catch {::grab $oldg}
422                    }
423                    return
424                }
425            }
426        }
427    } else {
428        set oldg [::grab current]
429        if { $oldg != "" } {
430            lappend _gstack [list $oldg [::grab status $oldg]]
431        }
432        if { $option == "global" } {
433            ::grab -global $path
434        } else {
435            ::grab $path
436        }
437    }
438}
439
440
441# ----------------------------------------------------------------------------
442#  Command BWidget::focus
443# ----------------------------------------------------------------------------
444proc BWidget::focus { option path {refocus 1} } {
445    variable _fstack
446
447    if { $option == "release" } {
448        while { [llength $_fstack] } {
449            set oldf [lindex $_fstack end]
450            set _fstack [lreplace $_fstack end end]
451            if { ![string equal $oldf $path] && [winfo exists $oldf] } {
452                if {$refocus} {catch {::focus -force $oldf}}
453                return
454            }
455        }
456    } elseif { $option == "set" } {
457        lappend _fstack [::focus]
458        ::focus -force $path
459    }
460}
461
462# BWidget::refocus --
463#
464#	Helper function used to redirect focus from a container frame in
465#	a megawidget to a component widget.  Only redirects focus if
466#	focus is already on the container.
467#
468# Arguments:
469#	container	container widget to redirect from.
470#	component	component widget to redirect to.
471#
472# Results:
473#	None.
474
475proc BWidget::refocus {container component} {
476    if { [string equal $container [::focus]] } {
477	::focus $component
478    }
479    return
480}
481
482## These mirror tk::(Set|Restore)FocusGrab
483
484# BWidget::SetFocusGrab --
485#   swap out current focus and grab temporarily (for dialogs)
486# Arguments:
487#   grab	new window to grab
488#   focus	window to give focus to
489# Results:
490#   Returns nothing
491#
492proc BWidget::SetFocusGrab {grab {focus {}}} {
493    variable _focusGrab
494    set index "$grab,$focus"
495
496    lappend _focusGrab($index) [::focus]
497    set oldGrab [::grab current $grab]
498    lappend _focusGrab($index) $oldGrab
499    if {[winfo exists $oldGrab]} {
500	lappend _focusGrab($index) [::grab status $oldGrab]
501    }
502    # The "grab" command will fail if another application
503    # already holds the grab.  So catch it.
504    catch {::grab $grab}
505    if {[winfo exists $focus]} {
506	::focus $focus
507    }
508}
509
510# BWidget::RestoreFocusGrab --
511#   restore old focus and grab (for dialogs)
512# Arguments:
513#   grab	window that had taken grab
514#   focus	window that had taken focus
515#   destroy	destroy|withdraw - how to handle the old grabbed window
516# Results:
517#   Returns nothing
518#
519proc BWidget::RestoreFocusGrab {grab focus {destroy destroy}} {
520    variable _focusGrab
521    set index "$grab,$focus"
522    if {[info exists _focusGrab($index)]} {
523	foreach {oldFocus oldGrab oldStatus} $_focusGrab($index) break
524	unset _focusGrab($index)
525    } else {
526	set oldGrab ""
527    }
528
529    catch {::focus $oldFocus}
530    ::grab release $grab
531    if {[string equal $destroy "withdraw"]} {
532	wm withdraw $grab
533    } else {
534	::destroy $grab
535    }
536    if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
537	if {[string equal $oldStatus "global"]} {
538	    ::grab -global $oldGrab
539	} else {
540	    ::grab $oldGrab
541	}
542    }
543}
544
545# BWidget::badOptionString --
546#
547#	Helper function to return a proper error string when an option
548#       doesn't match a list of given options.
549#
550# Arguments:
551#	type	A string that represents the type of option.
552#	value	The value that is in-valid.
553#       list	A list of valid options.
554#
555# Results:
556#	None.
557proc BWidget::badOptionString {type value list} {
558    set last [lindex $list end]
559    set list [lreplace $list end end]
560    return "bad $type \"$value\": must be [join $list ", "], or $last"
561}
562
563
564proc BWidget::wrongNumArgsString { string } {
565    return "wrong # args: should be \"$string\""
566}
567
568
569proc BWidget::read_file { file } {
570    set fp [open $file]
571    set x  [read $fp [file size $file]]
572    close $fp
573    return $x
574}
575
576
577proc BWidget::classes { class } {
578    variable use
579
580    ${class}::use
581    set classes [list $class]
582    if {![info exists use($class)]} { return }
583    foreach class $use($class) {
584	eval lappend classes [classes $class]
585    }
586    return [lsort -unique $classes]
587}
588
589
590proc BWidget::library { args } {
591    variable use
592
593    set libs    [list widget init utils]
594    set classes [list]
595    foreach class $args {
596	${class}::use
597        eval lappend classes [classes $class]
598    }
599
600    eval lappend libs [lsort -unique $classes]
601
602    set library ""
603    foreach lib $libs {
604	if {![info exists use($lib,file)]} {
605	    set file [file join $::BWIDGET::LIBRARY $lib.tcl]
606	} else {
607	    set file [file join $::BWIDGET::LIBRARY $use($lib,file).tcl]
608	}
609        append library [read_file $file]
610    }
611
612    return $library
613}
614
615
616proc BWidget::inuse { class } {
617    variable ::Widget::_inuse
618
619    if {![info exists _inuse($class)]} { return 0 }
620    return [expr $_inuse($class) > 0]
621}
622
623
624proc BWidget::write { filename {mode w} } {
625    variable use
626
627    if {![info exists use(classes)]} { return }
628
629    set classes [list]
630    foreach class $use(classes) {
631	if {![inuse $class]} { continue }
632	lappend classes $class
633    }
634
635    set fp [open $filename $mode]
636    puts $fp [eval library $classes]
637    close $fp
638
639    return
640}
641
642
643# BWidget::bindMouseWheel --
644#
645#	Bind mouse wheel actions to a given widget.
646#
647# Arguments:
648#	widget - The widget to bind.
649#
650# Results:
651#	None.
652proc BWidget::bindMouseWheel { widget } {
653    bind $widget <MouseWheel>         {%W yview scroll [expr {-%D/24}]  units}
654    bind $widget <Shift-MouseWheel>   {%W yview scroll [expr {-%D/120}] pages}
655    bind $widget <Control-MouseWheel> {%W yview scroll [expr {-%D/120}] units}
656
657    bind $widget <Button-4> {event generate %W <MouseWheel> -delta  120}
658    bind $widget <Button-5> {event generate %W <MouseWheel> -delta -120}
659}
660
661
662# ----------------------------------------------------------------------------
663#  widget.tcl
664#  This file is part of Unifix BWidget Toolkit
665#  $Id: widget.tcl,v 1.29 2005/07/28 00:40:42 hobbs Exp $
666# ----------------------------------------------------------------------------
667#  Index of commands:
668#     - Widget::tkinclude
669#     - Widget::bwinclude
670#     - Widget::declare
671#     - Widget::addmap
672#     - Widget::init
673#     - Widget::destroy
674#     - Widget::setoption
675#     - Widget::configure
676#     - Widget::cget
677#     - Widget::subcget
678#     - Widget::hasChanged
679#     - Widget::options
680#     - Widget::_get_tkwidget_options
681#     - Widget::_test_tkresource
682#     - Widget::_test_bwresource
683#     - Widget::_test_synonym
684#     - Widget::_test_string
685#     - Widget::_test_flag
686#     - Widget::_test_enum
687#     - Widget::_test_int
688#     - Widget::_test_boolean
689# ----------------------------------------------------------------------------
690# Each megawidget gets a namespace of the same name inside the Widget namespace
691# Each of these has an array opt, which contains information about the
692# megawidget options.  It maps megawidget options to a list with this format:
693#     {optionType defaultValue isReadonly {additionalOptionalInfo}}
694# Option types and their additional optional info are:
695#	TkResource	{genericTkWidget genericTkWidgetOptionName}
696#	BwResource	{nothing}
697#	Enum		{list of enumeration values}
698#	Int		{Boundary information}
699#	Boolean		{nothing}
700#	String		{nothing}
701#	Flag		{string of valid flag characters}
702#	Synonym		{nothing}
703#	Color		{nothing}
704#
705# Next, each namespace has an array map, which maps class options to their
706# component widget options:
707#	map(-foreground) => {.e -foreground .f -foreground}
708#
709# Each has an array ${path}:opt, which contains the value of each megawidget
710# option for a particular instance $path of the megawidget, and an array
711# ${path}:mod, which stores the "changed" status of configuration options.
712
713# Steps for creating a bwidget megawidget:
714# 1. parse args to extract subwidget spec
715# 2. Create frame with appropriate class and command line options
716# 3. Get initialization options from optionDB, using frame
717# 4. create subwidgets
718
719# Uses newer string operations
720package require Tcl 8.1.1
721
722namespace eval Widget {
723    variable _optiontype
724    variable _class
725    variable _tk_widget
726
727    # This controls whether we try to use themed widgets from Tile
728    variable _theme 0
729
730    variable _aqua [expr {($::tcl_version >= 8.4) &&
731			  [string equal [tk windowingsystem] "aqua"]}]
732
733    array set _optiontype {
734        TkResource Widget::_test_tkresource
735        BwResource Widget::_test_bwresource
736        Enum       Widget::_test_enum
737        Int        Widget::_test_int
738        Boolean    Widget::_test_boolean
739        String     Widget::_test_string
740        Flag       Widget::_test_flag
741        Synonym    Widget::_test_synonym
742        Color      Widget::_test_color
743        Padding    Widget::_test_padding
744    }
745
746    proc use {} {}
747}
748
749
750# ----------------------------------------------------------------------------
751#  Command Widget::tkinclude
752#     Includes tk widget resources to BWidget widget.
753#  class      class name of the BWidget
754#  tkwidget   tk widget to include
755#  subpath    subpath to configure
756#  args       additionnal args for included options
757# ----------------------------------------------------------------------------
758proc Widget::tkinclude { class tkwidget subpath args } {
759    foreach {cmd lopt} $args {
760        # cmd can be
761        #   include      options to include            lopt = {opt ...}
762        #   remove       options to remove             lopt = {opt ...}
763        #   rename       options to rename             lopt = {opt newopt ...}
764        #   prefix       options to prefix             lopt = {pref opt opt ..}
765        #   initialize   set default value for options lopt = {opt value ...}
766        #   readonly     set readonly flag for options lopt = {opt flag ...}
767        switch -- $cmd {
768            remove {
769                foreach option $lopt {
770                    set remove($option) 1
771                }
772            }
773            include {
774                foreach option $lopt {
775                    set include($option) 1
776                }
777            }
778            prefix {
779                set prefix [lindex $lopt 0]
780                foreach option [lrange $lopt 1 end] {
781                    set rename($option) "-$prefix[string range $option 1 end]"
782                }
783            }
784            rename     -
785            readonly   -
786            initialize {
787                array set $cmd $lopt
788            }
789            default {
790                return -code error "invalid argument \"$cmd\""
791            }
792        }
793    }
794
795    namespace eval $class {}
796    upvar 0 ${class}::opt classopt
797    upvar 0 ${class}::map classmap
798    upvar 0 ${class}::map$subpath submap
799    upvar 0 ${class}::optionExports exports
800
801    set foo [$tkwidget ".ericFoo###"]
802    # create resources informations from tk widget resources
803    foreach optdesc [_get_tkwidget_options $tkwidget] {
804        set option [lindex $optdesc 0]
805        if { (![info exists include] || [info exists include($option)]) &&
806             ![info exists remove($option)] } {
807            if { [llength $optdesc] == 3 } {
808                # option is a synonym
809                set syn [lindex $optdesc 1]
810                if { ![info exists remove($syn)] } {
811                    # original option is not removed
812                    if { [info exists rename($syn)] } {
813                        set classopt($option) [list Synonym $rename($syn)]
814                    } else {
815                        set classopt($option) [list Synonym $syn]
816                    }
817                }
818            } else {
819                if { [info exists rename($option)] } {
820                    set realopt $option
821                    set option  $rename($option)
822                } else {
823                    set realopt $option
824                }
825                if { [info exists initialize($option)] } {
826                    set value $initialize($option)
827                } else {
828                    set value [lindex $optdesc 1]
829                }
830                if { [info exists readonly($option)] } {
831                    set ro $readonly($option)
832                } else {
833                    set ro 0
834                }
835                set classopt($option) \
836			[list TkResource $value $ro [list $tkwidget $realopt]]
837
838		# Add an option database entry for this option
839		set optionDbName ".[lindex [_configure_option $option ""] 0]"
840		if { ![string equal $subpath ":cmd"] } {
841		    set optionDbName "$subpath$optionDbName"
842		}
843		option add *${class}$optionDbName $value widgetDefault
844		lappend exports($option) "$optionDbName"
845
846		# Store the forward and backward mappings for this
847		# option <-> realoption pair
848                lappend classmap($option) $subpath "" $realopt
849		set submap($realopt) $option
850            }
851        }
852    }
853    ::destroy $foo
854}
855
856
857# ----------------------------------------------------------------------------
858#  Command Widget::bwinclude
859#     Includes BWidget resources to BWidget widget.
860#  class    class name of the BWidget
861#  subclass BWidget class to include
862#  subpath  subpath to configure
863#  args     additionnal args for included options
864# ----------------------------------------------------------------------------
865proc Widget::bwinclude { class subclass subpath args } {
866    foreach {cmd lopt} $args {
867        # cmd can be
868        #   include      options to include            lopt = {opt ...}
869        #   remove       options to remove             lopt = {opt ...}
870        #   rename       options to rename             lopt = {opt newopt ...}
871        #   prefix       options to prefix             lopt = {prefix opt opt ...}
872        #   initialize   set default value for options lopt = {opt value ...}
873        #   readonly     set readonly flag for options lopt = {opt flag ...}
874        switch -- $cmd {
875            remove {
876                foreach option $lopt {
877                    set remove($option) 1
878                }
879            }
880            include {
881                foreach option $lopt {
882                    set include($option) 1
883                }
884            }
885            prefix {
886                set prefix [lindex $lopt 0]
887                foreach option [lrange $lopt 1 end] {
888                    set rename($option) "-$prefix[string range $option 1 end]"
889                }
890            }
891            rename     -
892            readonly   -
893            initialize {
894                array set $cmd $lopt
895            }
896            default {
897                return -code error "invalid argument \"$cmd\""
898            }
899        }
900    }
901
902    namespace eval $class {}
903    upvar 0 ${class}::opt classopt
904    upvar 0 ${class}::map classmap
905    upvar 0 ${class}::map$subpath submap
906    upvar 0 ${class}::optionExports exports
907    upvar 0 ${subclass}::opt subclassopt
908    upvar 0 ${subclass}::optionExports subexports
909
910    # create resources informations from BWidget resources
911    foreach {option optdesc} [array get subclassopt] {
912	set subOption $option
913        if { (![info exists include] || [info exists include($option)]) &&
914             ![info exists remove($option)] } {
915            set type [lindex $optdesc 0]
916            if { [string equal $type "Synonym"] } {
917                # option is a synonym
918                set syn [lindex $optdesc 1]
919                if { ![info exists remove($syn)] } {
920                    if { [info exists rename($syn)] } {
921                        set classopt($option) [list Synonym $rename($syn)]
922                    } else {
923                        set classopt($option) [list Synonym $syn]
924                    }
925                }
926            } else {
927                if { [info exists rename($option)] } {
928                    set realopt $option
929                    set option  $rename($option)
930                } else {
931                    set realopt $option
932                }
933                if { [info exists initialize($option)] } {
934                    set value $initialize($option)
935                } else {
936                    set value [lindex $optdesc 1]
937                }
938                if { [info exists readonly($option)] } {
939                    set ro $readonly($option)
940                } else {
941                    set ro [lindex $optdesc 2]
942                }
943                set classopt($option) \
944			[list $type $value $ro [lindex $optdesc 3]]
945
946		# Add an option database entry for this option
947		foreach optionDbName $subexports($subOption) {
948		    if { ![string equal $subpath ":cmd"] } {
949			set optionDbName "$subpath$optionDbName"
950		    }
951		    # Only add the option db entry if we are overriding the
952		    # normal widget default
953		    if { [info exists initialize($option)] } {
954			option add *${class}$optionDbName $value \
955				widgetDefault
956		    }
957		    lappend exports($option) "$optionDbName"
958		}
959
960		# Store the forward and backward mappings for this
961		# option <-> realoption pair
962                lappend classmap($option) $subpath $subclass $realopt
963		set submap($realopt) $option
964            }
965        }
966    }
967}
968
969
970# ----------------------------------------------------------------------------
971#  Command Widget::declare
972#    Declares new options to BWidget class.
973# ----------------------------------------------------------------------------
974proc Widget::declare { class optlist } {
975    variable _optiontype
976
977    namespace eval $class {}
978    upvar 0 ${class}::opt classopt
979    upvar 0 ${class}::optionExports exports
980    upvar 0 ${class}::optionClass optionClass
981
982    foreach optdesc $optlist {
983        set option  [lindex $optdesc 0]
984        set optdesc [lrange $optdesc 1 end]
985        set type    [lindex $optdesc 0]
986
987        if { ![info exists _optiontype($type)] } {
988            # invalid resource type
989            return -code error "invalid option type \"$type\""
990        }
991
992        if { [string equal $type "Synonym"] } {
993            # test existence of synonym option
994            set syn [lindex $optdesc 1]
995            if { ![info exists classopt($syn)] } {
996                return -code error "unknow option \"$syn\" for Synonym \"$option\""
997            }
998            set classopt($option) [list Synonym $syn]
999            continue
1000        }
1001
1002        # all other resource may have default value, readonly flag and
1003        # optional arg depending on type
1004        set value [lindex $optdesc 1]
1005        set ro    [lindex $optdesc 2]
1006        set arg   [lindex $optdesc 3]
1007
1008        if { [string equal $type "BwResource"] } {
1009            # We don't keep BwResource. We simplify to type of sub BWidget
1010            set subclass    [lindex $arg 0]
1011            set realopt     [lindex $arg 1]
1012            if { ![string length $realopt] } {
1013                set realopt $option
1014            }
1015
1016            upvar 0 ${subclass}::opt subclassopt
1017            if { ![info exists subclassopt($realopt)] } {
1018                return -code error "unknow option \"$realopt\""
1019            }
1020            set suboptdesc $subclassopt($realopt)
1021            if { $value == "" } {
1022                # We initialize default value
1023                set value [lindex $suboptdesc 1]
1024            }
1025            set type [lindex $suboptdesc 0]
1026            set ro   [lindex $suboptdesc 2]
1027            set arg  [lindex $suboptdesc 3]
1028	    set optionDbName ".[lindex [_configure_option $option ""] 0]"
1029	    option add *${class}${optionDbName} $value widgetDefault
1030	    set exports($option) $optionDbName
1031            set classopt($option) [list $type $value $ro $arg]
1032            continue
1033        }
1034
1035        # retreive default value for TkResource
1036        if { [string equal $type "TkResource"] } {
1037            set tkwidget [lindex $arg 0]
1038	    set foo [$tkwidget ".ericFoo##"]
1039            set realopt  [lindex $arg 1]
1040            if { ![string length $realopt] } {
1041                set realopt $option
1042            }
1043            set tkoptions [_get_tkwidget_options $tkwidget]
1044            if { ![string length $value] } {
1045                # We initialize default value
1046		set ind [lsearch $tkoptions [list $realopt *]]
1047                set value [lindex [lindex $tkoptions $ind] end]
1048            }
1049	    set optionDbName ".[lindex [_configure_option $option ""] 0]"
1050	    option add *${class}${optionDbName} $value widgetDefault
1051	    set exports($option) $optionDbName
1052            set classopt($option) [list TkResource $value $ro \
1053		    [list $tkwidget $realopt]]
1054	    set optionClass($option) [lindex [$foo configure $realopt] 1]
1055	    ::destroy $foo
1056            continue
1057        }
1058
1059	set optionDbName ".[lindex [_configure_option $option ""] 0]"
1060	option add *${class}${optionDbName} $value widgetDefault
1061	set exports($option) $optionDbName
1062        # for any other resource type, we keep original optdesc
1063        set classopt($option) [list $type $value $ro $arg]
1064    }
1065}
1066
1067
1068proc Widget::define { class filename args } {
1069    # variable ::BWidget::use
1070    set use($class)      $args
1071    set use($class,file) $filename
1072    lappend use(classes) $class
1073
1074    if {[set x [lsearch -exact $args "-classonly"]] > -1} {
1075	set args [lreplace $args $x $x]
1076    } else {
1077	interp alias {} ::${class} {} ${class}::create
1078	proc ::${class}::use {} {}
1079
1080	bind $class <Destroy> [list Widget::destroy %W]
1081    }
1082
1083    foreach class $args { ${class}::use }
1084}
1085
1086
1087proc Widget::create { class path {rename 1} } {
1088    if {$rename} { rename $path ::$path:cmd }
1089    proc ::$path { cmd args } \
1090    	[subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}]
1091    return $path
1092}
1093
1094
1095# ----------------------------------------------------------------------------
1096#  Command Widget::addmap
1097# ----------------------------------------------------------------------------
1098proc Widget::addmap { class subclass subpath options } {
1099    upvar 0 ${class}::opt classopt
1100    upvar 0 ${class}::optionExports exports
1101    upvar 0 ${class}::optionClass optionClass
1102    upvar 0 ${class}::map classmap
1103    upvar 0 ${class}::map$subpath submap
1104
1105    foreach {option realopt} $options {
1106        if { ![string length $realopt] } {
1107            set realopt $option
1108        }
1109	set val [lindex $classopt($option) 1]
1110	set optDb ".[lindex [_configure_option $realopt ""] 0]"
1111	if { ![string equal $subpath ":cmd"] } {
1112	    set optDb "$subpath$optDb"
1113	}
1114	option add *${class}${optDb} $val widgetDefault
1115	lappend exports($option) $optDb
1116	# Store the forward and backward mappings for this
1117	# option <-> realoption pair
1118        lappend classmap($option) $subpath $subclass $realopt
1119	set submap($realopt) $option
1120    }
1121}
1122
1123
1124# ----------------------------------------------------------------------------
1125#  Command Widget::syncoptions
1126# ----------------------------------------------------------------------------
1127proc Widget::syncoptions { class subclass subpath options } {
1128    upvar 0 ${class}::sync classync
1129
1130    foreach {option realopt} $options {
1131        if { ![string length $realopt] } {
1132            set realopt $option
1133        }
1134        set classync($option) [list $subpath $subclass $realopt]
1135    }
1136}
1137
1138
1139# ----------------------------------------------------------------------------
1140#  Command Widget::init
1141# ----------------------------------------------------------------------------
1142proc Widget::init { class path options } {
1143    variable _inuse
1144
1145    upvar 0 ${class}::opt classopt
1146    upvar 0 ${class}::$path:opt  pathopt
1147    upvar 0 ${class}::$path:mod  pathmod
1148    upvar 0 ${class}::map classmap
1149    upvar 0 ${class}::$path:init pathinit
1150
1151    if { [info exists pathopt] } {
1152	unset pathopt
1153    }
1154    if { [info exists pathmod] } {
1155	unset pathmod
1156    }
1157    # We prefer to use the actual widget for option db queries, but if it
1158    # doesn't exist yet, do the next best thing:  create a widget of the
1159    # same class and use that.
1160    set fpath $path
1161    set rdbclass [string map [list :: ""] $class]
1162    if { ![winfo exists $path] } {
1163	set fpath ".#BWidget.#Class#$class"
1164	# encapsulation frame to not pollute '.' childspace
1165	if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
1166	if { ![winfo exists $fpath] } {
1167	    frame $fpath -class $rdbclass
1168	}
1169    }
1170    foreach {option optdesc} [array get classopt] {
1171        set pathmod($option) 0
1172	if { [info exists classmap($option)] } {
1173	    continue
1174	}
1175        set type [lindex $optdesc 0]
1176        if { [string equal $type "Synonym"] } {
1177	    continue
1178        }
1179        if { [string equal $type "TkResource"] } {
1180            set alt [lindex [lindex $optdesc 3] 1]
1181        } else {
1182            set alt ""
1183        }
1184        set optdb [lindex [_configure_option $option $alt] 0]
1185        set def   [option get $fpath $optdb $rdbclass]
1186        if { [string length $def] } {
1187            set pathopt($option) $def
1188        } else {
1189            set pathopt($option) [lindex $optdesc 1]
1190        }
1191    }
1192
1193    if {![info exists _inuse($class)]} { set _inuse($class) 0 }
1194    incr _inuse($class)
1195
1196    set Widget::_class($path) $class
1197    foreach {option value} $options {
1198        if { ![info exists classopt($option)] } {
1199            unset pathopt
1200            unset pathmod
1201            return -code error "unknown option \"$option\""
1202        }
1203        set optdesc $classopt($option)
1204        set type    [lindex $optdesc 0]
1205        if { [string equal $type "Synonym"] } {
1206            set option  [lindex $optdesc 1]
1207            set optdesc $classopt($option)
1208            set type    [lindex $optdesc 0]
1209        }
1210        set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
1211	set pathinit($option) $pathopt($option)
1212    }
1213}
1214
1215# Bastien Chevreux (bach@mwgdna.com)
1216#
1217# copyinit performs basically the same job as init, but it uses a
1218#  existing template to initialize its values. So, first a perferct copy
1219#  from the template is made just to be altered by any existing options
1220#  afterwards.
1221# But this still saves time as the first initialization parsing block is
1222#  skipped.
1223# As additional bonus, items that differ in just a few options can be
1224#  initialized faster by leaving out the options that are equal.
1225
1226# This function is currently used only by ListBox::multipleinsert, but other
1227#  calls should follow :)
1228
1229# ----------------------------------------------------------------------------
1230#  Command Widget::copyinit
1231# ----------------------------------------------------------------------------
1232proc Widget::copyinit { class templatepath path options } {
1233    upvar 0 ${class}::opt classopt \
1234	    ${class}::$path:opt	 pathopt \
1235	    ${class}::$path:mod	 pathmod \
1236	    ${class}::$path:init pathinit \
1237	    ${class}::$templatepath:opt	  templatepathopt \
1238	    ${class}::$templatepath:mod	  templatepathmod \
1239	    ${class}::$templatepath:init  templatepathinit
1240
1241    if { [info exists pathopt] } {
1242	unset pathopt
1243    }
1244    if { [info exists pathmod] } {
1245	unset pathmod
1246    }
1247
1248    # We use the template widget for option db copying, but it has to exist!
1249    array set pathmod  [array get templatepathmod]
1250    array set pathopt  [array get templatepathopt]
1251    array set pathinit [array get templatepathinit]
1252
1253    set Widget::_class($path) $class
1254    foreach {option value} $options {
1255	if { ![info exists classopt($option)] } {
1256	    unset pathopt
1257	    unset pathmod
1258	    return -code error "unknown option \"$option\""
1259	}
1260	set optdesc $classopt($option)
1261	set type    [lindex $optdesc 0]
1262	if { [string equal $type "Synonym"] } {
1263	    set option	[lindex $optdesc 1]
1264	    set optdesc $classopt($option)
1265	    set type	[lindex $optdesc 0]
1266	}
1267	set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
1268	set pathinit($option) $pathopt($option)
1269    }
1270}
1271
1272# Widget::parseArgs --
1273#
1274#	Given a widget class and a command-line spec, cannonize and validate
1275#	the given options, and return a keyed list consisting of the
1276#	component widget and its masked portion of the command-line spec, and
1277#	one extra entry consisting of the portion corresponding to the
1278#	megawidget itself.
1279#
1280# Arguments:
1281#	class	widget class to parse for.
1282#	options	command-line spec
1283#
1284# Results:
1285#	result	keyed list of portions of the megawidget and that segment of
1286#		the command line in which that portion is interested.
1287
1288proc Widget::parseArgs {class options} {
1289    upvar 0 ${class}::opt classopt
1290    upvar 0 ${class}::map classmap
1291
1292    foreach {option val} $options {
1293	if { ![info exists classopt($option)] } {
1294	    error "unknown option \"$option\""
1295	}
1296        set optdesc $classopt($option)
1297        set type    [lindex $optdesc 0]
1298        if { [string equal $type "Synonym"] } {
1299            set option  [lindex $optdesc 1]
1300            set optdesc $classopt($option)
1301            set type    [lindex $optdesc 0]
1302        }
1303	if { [string equal $type "TkResource"] } {
1304	    # Make sure that the widget used for this TkResource exists
1305	    Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0]
1306	}
1307	set val [$Widget::_optiontype($type) $option $val [lindex $optdesc 3]]
1308
1309	if { [info exists classmap($option)] } {
1310	    foreach {subpath subclass realopt} $classmap($option) {
1311		lappend maps($subpath) $realopt $val
1312	    }
1313	} else {
1314	    lappend maps($class) $option $val
1315	}
1316    }
1317    return [array get maps]
1318}
1319
1320# Widget::initFromODB --
1321#
1322#	Initialize a megawidgets options with information from the option
1323#	database and from the command-line arguments given.
1324#
1325# Arguments:
1326#	class	class of the widget.
1327#	path	path of the widget -- should already exist.
1328#	options	command-line arguments.
1329#
1330# Results:
1331#	None.
1332
1333proc Widget::initFromODB {class path options} {
1334    variable _inuse
1335    variable _class
1336
1337    upvar 0 ${class}::$path:opt  pathopt
1338    upvar 0 ${class}::$path:mod  pathmod
1339    upvar 0 ${class}::map classmap
1340
1341    if { [info exists pathopt] } {
1342	unset pathopt
1343    }
1344    if { [info exists pathmod] } {
1345	unset pathmod
1346    }
1347    # We prefer to use the actual widget for option db queries, but if it
1348    # doesn't exist yet, do the next best thing:  create a widget of the
1349    # same class and use that.
1350    set fpath [_get_window $class $path]
1351    set rdbclass [string map [list :: ""] $class]
1352    if { ![winfo exists $path] } {
1353	set fpath ".#BWidget.#Class#$class"
1354	# encapsulation frame to not pollute '.' childspace
1355	if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
1356	if { ![winfo exists $fpath] } {
1357	    frame $fpath -class $rdbclass
1358	}
1359    }
1360
1361    foreach {option optdesc} [array get ${class}::opt] {
1362        set pathmod($option) 0
1363	if { [info exists classmap($option)] } {
1364	    continue
1365	}
1366        set type [lindex $optdesc 0]
1367        if { [string equal $type "Synonym"] } {
1368	    continue
1369        }
1370	if { [string equal $type "TkResource"] } {
1371            set alt [lindex [lindex $optdesc 3] 1]
1372        } else {
1373            set alt ""
1374        }
1375        set optdb [lindex [_configure_option $option $alt] 0]
1376        set def   [option get $fpath $optdb $rdbclass]
1377        if { [string length $def] } {
1378            set pathopt($option) $def
1379        } else {
1380            set pathopt($option) [lindex $optdesc 1]
1381        }
1382    }
1383
1384    if {![info exists _inuse($class)]} { set _inuse($class) 0 }
1385    incr _inuse($class)
1386
1387    set _class($path) $class
1388    array set pathopt $options
1389}
1390
1391
1392
1393# ----------------------------------------------------------------------------
1394#  Command Widget::destroy
1395# ----------------------------------------------------------------------------
1396proc Widget::destroy { path } {
1397    variable _class
1398    variable _inuse
1399
1400    if {![info exists _class($path)]} { return }
1401
1402    set class $_class($path)
1403    upvar 0 ${class}::$path:opt pathopt
1404    upvar 0 ${class}::$path:mod pathmod
1405    upvar 0 ${class}::$path:init pathinit
1406
1407    if {[info exists _inuse($class)]} { incr _inuse($class) -1 }
1408
1409    if {[info exists pathopt]} {
1410        unset pathopt
1411    }
1412    if {[info exists pathmod]} {
1413        unset pathmod
1414    }
1415    if {[info exists pathinit]} {
1416        unset pathinit
1417    }
1418
1419    if {![string equal [info commands $path] ""]} { rename $path "" }
1420
1421    ## Unset any variables used in this widget.
1422    foreach var [info vars ::${class}::$path:*] { unset $var }
1423
1424    unset _class($path)
1425}
1426
1427
1428# ----------------------------------------------------------------------------
1429#  Command Widget::configure
1430# ----------------------------------------------------------------------------
1431proc Widget::configure { path options } {
1432    set len [llength $options]
1433    if { $len <= 1 } {
1434        return [_get_configure $path $options]
1435    } elseif { $len % 2 == 1 } {
1436        return -code error "incorrect number of arguments"
1437    }
1438
1439    variable _class
1440    variable _optiontype
1441
1442    set class $_class($path)
1443    upvar 0 ${class}::opt  classopt
1444    upvar 0 ${class}::map  classmap
1445    upvar 0 ${class}::$path:opt pathopt
1446    upvar 0 ${class}::$path:mod pathmod
1447
1448    set window [_get_window $class $path]
1449    foreach {option value} $options {
1450        if { ![info exists classopt($option)] } {
1451            return -code error "unknown option \"$option\""
1452        }
1453        set optdesc $classopt($option)
1454        set type    [lindex $optdesc 0]
1455        if { [string equal $type "Synonym"] } {
1456            set option  [lindex $optdesc 1]
1457            set optdesc $classopt($option)
1458            set type    [lindex $optdesc 0]
1459        }
1460        if { ![lindex $optdesc 2] } {
1461            set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
1462            if { [info exists classmap($option)] } {
1463		set window [_get_window $class $window]
1464                foreach {subpath subclass realopt} $classmap($option) {
1465                    if { [string length $subclass] } {
1466			set curval [${subclass}::cget $window$subpath $realopt]
1467                        ${subclass}::configure $window$subpath $realopt $newval
1468                    } else {
1469			set curval [$window$subpath cget $realopt]
1470                        $window$subpath configure $realopt $newval
1471                    }
1472                }
1473            } else {
1474		set curval $pathopt($option)
1475		set pathopt($option) $newval
1476	    }
1477	    set pathmod($option) [expr {![string equal $newval $curval]}]
1478        }
1479    }
1480
1481    return {}
1482}
1483
1484
1485# ----------------------------------------------------------------------------
1486#  Command Widget::cget
1487# ----------------------------------------------------------------------------
1488proc Widget::cget { path option } {
1489    if { ![info exists ::Widget::_class($path)] } {
1490        return -code error "unknown widget $path"
1491    }
1492
1493    set class $::Widget::_class($path)
1494    if { ![info exists ${class}::opt($option)] } {
1495        return -code error "unknown option \"$option\""
1496    }
1497
1498    set optdesc [set ${class}::opt($option)]
1499    set type    [lindex $optdesc 0]
1500    if {[string equal $type "Synonym"]} {
1501        set option [lindex $optdesc 1]
1502    }
1503
1504    if { [info exists ${class}::map($option)] } {
1505	foreach {subpath subclass realopt} [set ${class}::map($option)] {break}
1506	set path "[_get_window $class $path]$subpath"
1507	return [$path cget $realopt]
1508    }
1509    upvar 0 ${class}::$path:opt pathopt
1510    set pathopt($option)
1511}
1512
1513
1514# ----------------------------------------------------------------------------
1515#  Command Widget::subcget
1516# ----------------------------------------------------------------------------
1517proc Widget::subcget { path subwidget } {
1518    set class $::Widget::_class($path)
1519    upvar 0 ${class}::$path:opt pathopt
1520    upvar 0 ${class}::map$subwidget submap
1521    upvar 0 ${class}::$path:init pathinit
1522
1523    set result {}
1524    foreach realopt [array names submap] {
1525	if { [info exists pathinit($submap($realopt))] } {
1526	    lappend result $realopt $pathopt($submap($realopt))
1527	}
1528    }
1529    return $result
1530}
1531
1532
1533# ----------------------------------------------------------------------------
1534#  Command Widget::hasChanged
1535# ----------------------------------------------------------------------------
1536proc Widget::hasChanged { path option pvalue } {
1537    upvar    $pvalue value
1538    set class $::Widget::_class($path)
1539    upvar 0 ${class}::$path:mod pathmod
1540
1541    set value   [Widget::cget $path $option]
1542    set result  $pathmod($option)
1543    set pathmod($option) 0
1544
1545    return $result
1546}
1547
1548proc Widget::hasChangedX { path option args } {
1549    set class $::Widget::_class($path)
1550    upvar 0 ${class}::$path:mod pathmod
1551
1552    set result  $pathmod($option)
1553    set pathmod($option) 0
1554    foreach option $args {
1555	lappend result $pathmod($option)
1556	set pathmod($option) 0
1557    }
1558
1559    set result
1560}
1561
1562
1563# ----------------------------------------------------------------------------
1564#  Command Widget::setoption
1565# ----------------------------------------------------------------------------
1566proc Widget::setoption { path option value } {
1567#    variable _class
1568
1569#    set class $_class($path)
1570#    upvar 0 ${class}::$path:opt pathopt
1571
1572#    set pathopt($option) $value
1573    Widget::configure $path [list $option $value]
1574}
1575
1576
1577# ----------------------------------------------------------------------------
1578#  Command Widget::getoption
1579# ----------------------------------------------------------------------------
1580proc Widget::getoption { path option } {
1581#    set class $::Widget::_class($path)
1582#    upvar 0 ${class}::$path:opt pathopt
1583
1584#    return $pathopt($option)
1585    return [Widget::cget $path $option]
1586}
1587
1588# Widget::getMegawidgetOption --
1589#
1590#	Bypass the superfluous checks in cget and just directly peer at the
1591#	widget's data space.  This is much more fragile than cget, so it
1592#	should only be used with great care, in places where speed is critical.
1593#
1594# Arguments:
1595#	path	widget to lookup options for.
1596#	option	option to retrieve.
1597#
1598# Results:
1599#	value	option value.
1600
1601proc Widget::getMegawidgetOption {path option} {
1602    set class $::Widget::_class($path)
1603    upvar 0 ${class}::${path}:opt pathopt
1604    set pathopt($option)
1605}
1606
1607# Widget::setMegawidgetOption --
1608#
1609#	Bypass the superfluous checks in cget and just directly poke at the
1610#	widget's data space.  This is much more fragile than configure, so it
1611#	should only be used with great care, in places where speed is critical.
1612#
1613# Arguments:
1614#	path	widget to lookup options for.
1615#	option	option to retrieve.
1616#	value	option value.
1617#
1618# Results:
1619#	value	option value.
1620
1621proc Widget::setMegawidgetOption {path option value} {
1622    set class $::Widget::_class($path)
1623    upvar 0 ${class}::${path}:opt pathopt
1624    set pathopt($option) $value
1625}
1626
1627# ----------------------------------------------------------------------------
1628#  Command Widget::_get_window
1629#  returns the window corresponding to widget path
1630# ----------------------------------------------------------------------------
1631proc Widget::_get_window { class path } {
1632    set idx [string last "#" $path]
1633    if { $idx != -1 && [string equal [string range $path [expr {$idx+1}] end] $class] } {
1634        return [string range $path 0 [expr {$idx-1}]]
1635    } else {
1636        return $path
1637    }
1638}
1639
1640
1641# ----------------------------------------------------------------------------
1642#  Command Widget::_get_configure
1643#  returns the configuration list of options
1644#  (as tk widget do - [$w configure ?option?])
1645# ----------------------------------------------------------------------------
1646proc Widget::_get_configure { path options } {
1647    variable _class
1648
1649    set class $_class($path)
1650    upvar 0 ${class}::opt classopt
1651    upvar 0 ${class}::map classmap
1652    upvar 0 ${class}::$path:opt pathopt
1653    upvar 0 ${class}::$path:mod pathmod
1654
1655    set len [llength $options]
1656    if { !$len } {
1657        set result {}
1658        foreach option [lsort [array names classopt]] {
1659            set optdesc $classopt($option)
1660            set type    [lindex $optdesc 0]
1661            if { [string equal $type "Synonym"] } {
1662                set syn     $option
1663                set option  [lindex $optdesc 1]
1664                set optdesc $classopt($option)
1665                set type    [lindex $optdesc 0]
1666            } else {
1667                set syn ""
1668            }
1669            if { [string equal $type "TkResource"] } {
1670                set alt [lindex [lindex $optdesc 3] 1]
1671            } else {
1672                set alt ""
1673            }
1674            set res [_configure_option $option $alt]
1675            if { $syn == "" } {
1676                lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
1677            } else {
1678                lappend result [list $syn [lindex $res 0]]
1679            }
1680        }
1681        return $result
1682    } elseif { $len == 1 } {
1683        set option  [lindex $options 0]
1684        if { ![info exists classopt($option)] } {
1685            return -code error "unknown option \"$option\""
1686        }
1687        set optdesc $classopt($option)
1688        set type    [lindex $optdesc 0]
1689        if { [string equal $type "Synonym"] } {
1690            set option  [lindex $optdesc 1]
1691            set optdesc $classopt($option)
1692            set type    [lindex $optdesc 0]
1693        }
1694        if { [string equal $type "TkResource"] } {
1695            set alt [lindex [lindex $optdesc 3] 1]
1696        } else {
1697            set alt ""
1698        }
1699        set res [_configure_option $option $alt]
1700        return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
1701    }
1702}
1703
1704
1705# ----------------------------------------------------------------------------
1706#  Command Widget::_configure_option
1707# ----------------------------------------------------------------------------
1708proc Widget::_configure_option { option altopt } {
1709    variable _optiondb
1710    variable _optionclass
1711
1712    if { [info exists _optiondb($option)] } {
1713        set optdb $_optiondb($option)
1714    } else {
1715        set optdb [string range $option 1 end]
1716    }
1717    if { [info exists _optionclass($option)] } {
1718        set optclass $_optionclass($option)
1719    } elseif { [string length $altopt] } {
1720        if { [info exists _optionclass($altopt)] } {
1721            set optclass $_optionclass($altopt)
1722        } else {
1723            set optclass [string range $altopt 1 end]
1724        }
1725    } else {
1726        set optclass [string range $option 1 end]
1727    }
1728    return [list $optdb $optclass]
1729}
1730
1731
1732# ----------------------------------------------------------------------------
1733#  Command Widget::_get_tkwidget_options
1734# ----------------------------------------------------------------------------
1735proc Widget::_get_tkwidget_options { tkwidget } {
1736    variable _tk_widget
1737    variable _optiondb
1738    variable _optionclass
1739
1740    set widget ".#BWidget.#$tkwidget"
1741    # encapsulation frame to not pollute '.' childspace
1742    if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
1743    if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } {
1744	set widget [$tkwidget $widget]
1745	# JDC: Withdraw toplevels, otherwise visible
1746	if {[string equal $tkwidget "toplevel"]} {
1747	    wm withdraw $widget
1748	}
1749	set config [$widget configure]
1750	foreach optlist $config {
1751	    set opt [lindex $optlist 0]
1752	    if { [llength $optlist] == 2 } {
1753		set refsyn [lindex $optlist 1]
1754		# search for class
1755		set idx [lsearch $config [list * $refsyn *]]
1756		if { $idx == -1 } {
1757		    if { [string index $refsyn 0] == "-" } {
1758			# search for option (tk8.1b1 bug)
1759			set idx [lsearch $config [list $refsyn * *]]
1760		    } else {
1761			# last resort
1762			set idx [lsearch $config [list -[string tolower $refsyn] * *]]
1763		    }
1764		    if { $idx == -1 } {
1765			# fed up with "can't read classopt()"
1766			return -code error "can't find option of synonym $opt"
1767		    }
1768		}
1769		set syn [lindex [lindex $config $idx] 0]
1770		# JDC: used 4 (was 3) to get def from optiondb
1771		set def [lindex [lindex $config $idx] 4]
1772		lappend _tk_widget($tkwidget) [list $opt $syn $def]
1773	    } else {
1774		# JDC: used 4 (was 3) to get def from optiondb
1775		set def [lindex $optlist 4]
1776		lappend _tk_widget($tkwidget) [list $opt $def]
1777		set _optiondb($opt)    [lindex $optlist 1]
1778		set _optionclass($opt) [lindex $optlist 2]
1779	    }
1780	}
1781    }
1782    return $_tk_widget($tkwidget)
1783}
1784
1785
1786# ----------------------------------------------------------------------------
1787#  Command Widget::_test_tkresource
1788# ----------------------------------------------------------------------------
1789proc Widget::_test_tkresource { option value arg } {
1790#    set tkwidget [lindex $arg 0]
1791#    set realopt  [lindex $arg 1]
1792    foreach {tkwidget realopt} $arg break
1793    set path     ".#BWidget.#$tkwidget"
1794    set old      [$path cget $realopt]
1795    $path configure $realopt $value
1796    set res      [$path cget $realopt]
1797    $path configure $realopt $old
1798
1799    return $res
1800}
1801
1802
1803# ----------------------------------------------------------------------------
1804#  Command Widget::_test_bwresource
1805# ----------------------------------------------------------------------------
1806proc Widget::_test_bwresource { option value arg } {
1807    return -code error "bad option type BwResource in widget"
1808}
1809
1810
1811# ----------------------------------------------------------------------------
1812#  Command Widget::_test_synonym
1813# ----------------------------------------------------------------------------
1814proc Widget::_test_synonym { option value arg } {
1815    return -code error "bad option type Synonym in widget"
1816}
1817
1818# ----------------------------------------------------------------------------
1819#  Command Widget::_test_color
1820# ----------------------------------------------------------------------------
1821proc Widget::_test_color { option value arg } {
1822    if {[catch {winfo rgb . $value} color]} {
1823        return -code error "bad $option value \"$value\": must be a colorname \
1824		or #RRGGBB triplet"
1825    }
1826
1827    return $value
1828}
1829
1830
1831# ----------------------------------------------------------------------------
1832#  Command Widget::_test_string
1833# ----------------------------------------------------------------------------
1834proc Widget::_test_string { option value arg } {
1835    set value
1836}
1837
1838
1839# ----------------------------------------------------------------------------
1840#  Command Widget::_test_flag
1841# ----------------------------------------------------------------------------
1842proc Widget::_test_flag { option value arg } {
1843    set len [string length $value]
1844    set res ""
1845    for {set i 0} {$i < $len} {incr i} {
1846        set c [string index $value $i]
1847        if { [string first $c $arg] == -1 } {
1848            return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
1849        }
1850        if { [string first $c $res] == -1 } {
1851            append res $c
1852        }
1853    }
1854    return $res
1855}
1856
1857
1858# -----------------------------------------------------------------------------
1859#  Command Widget::_test_enum
1860# -----------------------------------------------------------------------------
1861proc Widget::_test_enum { option value arg } {
1862    if { [lsearch $arg $value] == -1 } {
1863        set last [lindex   $arg end]
1864        set sub  [lreplace $arg end end]
1865        if { [llength $sub] } {
1866            set str "[join $sub ", "] or $last"
1867        } else {
1868            set str $last
1869        }
1870        return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
1871    }
1872    return $value
1873}
1874
1875
1876# -----------------------------------------------------------------------------
1877#  Command Widget::_test_int
1878# -----------------------------------------------------------------------------
1879proc Widget::_test_int { option value arg } {
1880    if { ![string is int -strict $value] || \
1881	    ([string length $arg] && \
1882	    ![expr [string map [list %d $value] $arg]]) } {
1883		    return -code error "bad $option value\
1884			    \"$value\": must be integer ($arg)"
1885    }
1886    return $value
1887}
1888
1889
1890# -----------------------------------------------------------------------------
1891#  Command Widget::_test_boolean
1892# -----------------------------------------------------------------------------
1893proc Widget::_test_boolean { option value arg } {
1894    if { ![string is boolean -strict $value] } {
1895        return -code error "bad $option value \"$value\": must be boolean"
1896    }
1897
1898    # Get the canonical form of the boolean value (1 for true, 0 for false)
1899    return [string is true $value]
1900}
1901
1902
1903# -----------------------------------------------------------------------------
1904#  Command Widget::_test_padding
1905# -----------------------------------------------------------------------------
1906proc Widget::_test_padding { option values arg } {
1907    set len [llength $values]
1908    if {$len < 1 || $len > 2} {
1909        return -code error "bad pad value \"$values\":\
1910                        must be positive screen distance"
1911    }
1912
1913    foreach value $values {
1914        if { ![string is int -strict $value] || \
1915            ([string length $arg] && \
1916            ![expr [string map [list %d $value] $arg]]) } {
1917                return -code error "bad pad value \"$value\":\
1918                                must be positive screen distance ($arg)"
1919        }
1920    }
1921    return $values
1922}
1923
1924
1925# Widget::_get_padding --
1926#
1927#       Return the requesting padding value for a padding option.
1928#
1929# Arguments:
1930#	path		Widget to get the options for.
1931#       option          The name of the padding option.
1932#	index		The index of the padding.  If the index is empty,
1933#                       the first padding value is returned.
1934#
1935# Results:
1936#	Return a numeric value that can be used for padding.
1937proc Widget::_get_padding { path option {index 0} } {
1938    set pad [Widget::cget $path $option]
1939    set val [lindex $pad $index]
1940    if {$val == ""} { set val [lindex $pad 0] }
1941    return $val
1942}
1943
1944
1945# -----------------------------------------------------------------------------
1946#  Command Widget::focusNext
1947#  Same as tk_focusNext, but call Widget::focusOK
1948# -----------------------------------------------------------------------------
1949proc Widget::focusNext { w } {
1950    set cur $w
1951    while 1 {
1952
1953	# Descend to just before the first child of the current widget.
1954
1955	set parent $cur
1956	set children [winfo children $cur]
1957	set i -1
1958
1959	# Look for the next sibling that isn't a top-level.
1960
1961	while 1 {
1962	    incr i
1963	    if {$i < [llength $children]} {
1964		set cur [lindex $children $i]
1965		if {[string equal [winfo toplevel $cur] $cur]} {
1966		    continue
1967		} else {
1968		    break
1969		}
1970	    }
1971
1972	    # No more siblings, so go to the current widget's parent.
1973	    # If it's a top-level, break out of the loop, otherwise
1974	    # look for its next sibling.
1975
1976	    set cur $parent
1977	    if {[string equal [winfo toplevel $cur] $cur]} {
1978		break
1979	    }
1980	    set parent [winfo parent $parent]
1981	    set children [winfo children $parent]
1982	    set i [lsearch -exact $children $cur]
1983	}
1984	if {[string equal $cur $w] || [focusOK $cur]} {
1985	    return $cur
1986	}
1987    }
1988}
1989
1990
1991# -----------------------------------------------------------------------------
1992#  Command Widget::focusPrev
1993#  Same as tk_focusPrev, except:
1994#	+ Don't traverse from a child to a direct ancestor
1995#	+ Call Widget::focusOK instead of tk::focusOK
1996# -----------------------------------------------------------------------------
1997proc Widget::focusPrev { w } {
1998    set cur $w
1999    set origParent [winfo parent $w]
2000    while 1 {
2001
2002	# Collect information about the current window's position
2003	# among its siblings.  Also, if the window is a top-level,
2004	# then reposition to just after the last child of the window.
2005
2006	if {[string equal [winfo toplevel $cur] $cur]}  {
2007	    set parent $cur
2008	    set children [winfo children $cur]
2009	    set i [llength $children]
2010	} else {
2011	    set parent [winfo parent $cur]
2012	    set children [winfo children $parent]
2013	    set i [lsearch -exact $children $cur]
2014	}
2015
2016	# Go to the previous sibling, then descend to its last descendant
2017	# (highest in stacking order.  While doing this, ignore top-levels
2018	# and their descendants.  When we run out of descendants, go up
2019	# one level to the parent.
2020
2021	while {$i > 0} {
2022	    incr i -1
2023	    set cur [lindex $children $i]
2024	    if {[string equal [winfo toplevel $cur] $cur]} {
2025		continue
2026	    }
2027	    set parent $cur
2028	    set children [winfo children $parent]
2029	    set i [llength $children]
2030	}
2031	set cur $parent
2032	if {[string equal $cur $w]} {
2033	    return $cur
2034	}
2035	# If we are just at the original parent of $w, skip it as a
2036	# potential focus accepter.  Extra safety in this is to see if
2037	# that parent is also a proc (not a C command), which is what
2038	# BWidgets makes for any megawidget.  Could possibly also check
2039	# for '[info commands ::${origParent}:cmd] != ""'.  [Bug 765667]
2040	if {[string equal $cur $origParent]
2041	    && [info procs ::$origParent] != ""} {
2042	    continue
2043	}
2044	if {[focusOK $cur]} {
2045	    return $cur
2046	}
2047    }
2048}
2049
2050
2051# ----------------------------------------------------------------------------
2052#  Command Widget::focusOK
2053#  Same as tk_focusOK, but handles -editable option and whole tags list.
2054# ----------------------------------------------------------------------------
2055proc Widget::focusOK { w } {
2056    set code [catch {$w cget -takefocus} value]
2057    if { $code == 1 } {
2058        return 0
2059    }
2060    if {($code == 0) && ($value != "")} {
2061	if {$value == 0} {
2062	    return 0
2063	} elseif {$value == 1} {
2064	    return [winfo viewable $w]
2065	} else {
2066	    set value [uplevel \#0 $value $w]
2067            if {$value != ""} {
2068		return $value
2069	    }
2070        }
2071    }
2072    if {![winfo viewable $w]} {
2073	return 0
2074    }
2075    set code [catch {$w cget -state} value]
2076    if {($code == 0) && ($value == "disabled")} {
2077	return 0
2078    }
2079    set code [catch {$w cget -editable} value]
2080    if {($code == 0) && ($value == 0)} {
2081        return 0
2082    }
2083
2084    set top [winfo toplevel $w]
2085    foreach tags [bindtags $w] {
2086        if { ![string equal $tags $top]  &&
2087             ![string equal $tags "all"] &&
2088             [regexp Key [bind $tags]] } {
2089            return 1
2090        }
2091    }
2092    return 0
2093}
2094
2095
2096proc Widget::traverseTo { w } {
2097    set focus [focus]
2098    if {![string equal $focus ""]} {
2099	event generate $focus <<TraverseOut>>
2100    }
2101    focus $w
2102
2103    event generate $w <<TraverseIn>>
2104}
2105
2106
2107# Widget::varForOption --
2108#
2109#	Retrieve a fully qualified variable name for the option specified.
2110#	If the option is not one for which a variable exists, throw an error
2111#	(ie, those options that map directly to widget options).
2112#
2113# Arguments:
2114#	path	megawidget to get an option var for.
2115#	option	option to get a var for.
2116#
2117# Results:
2118#	varname	name of the variable, fully qualified, suitable for tracing.
2119
2120proc Widget::varForOption {path option} {
2121    variable _class
2122    variable _optiontype
2123
2124    set class $_class($path)
2125    upvar 0 ${class}::$path:opt pathopt
2126
2127    if { ![info exists pathopt($option)] } {
2128	error "unable to find variable for option \"$option\""
2129    }
2130    set varname "::Widget::${class}::$path:opt($option)"
2131    return $varname
2132}
2133
2134# Widget::getVariable --
2135#
2136#       Get a variable from within the namespace of the widget.
2137#
2138# Arguments:
2139#	path		Megawidget to get the variable for.
2140#	varName		The variable name to retrieve.
2141#       newVarName	The variable name to refer to in the calling proc.
2142#
2143# Results:
2144#	Creates a reference to newVarName in the calling proc.
2145proc Widget::getVariable { path varName {newVarName ""} } {
2146    variable _class
2147    set class $_class($path)
2148    if {![string length $newVarName]} { set newVarName $varName }
2149    uplevel 1 [list upvar \#0 ${class}::$path:$varName $newVarName]
2150}
2151
2152# Widget::options --
2153#
2154#       Return a key-value list of options for a widget.  This can
2155#       be used to serialize the options of a widget and pass them
2156#       on to a new widget with the same options.
2157#
2158# Arguments:
2159#	path		Widget to get the options for.
2160#	args		A list of options.  If empty, all options are returned.
2161#
2162# Results:
2163#	Returns list of options as: -option value -option value ...
2164proc Widget::options { path args } {
2165    if {[llength $args]} {
2166        foreach option $args {
2167            lappend options [_get_configure $path $option]
2168        }
2169    } else {
2170        set options [_get_configure $path {}]
2171    }
2172
2173    set result [list]
2174    foreach list $options {
2175        if {[llength $list] < 5} { continue }
2176        lappend result [lindex $list 0] [lindex $list end]
2177    }
2178    return $result
2179}
2180
2181
2182# Widget::getOption --
2183#
2184#	Given a list of widgets, determine which option value to use.
2185#	The widgets are given to the command in order of highest to
2186#	lowest.  Starting with the lowest widget, whichever one does
2187#	not match the default option value is returned as the value.
2188#	If all the widgets are default, we return the highest widget's
2189#	value.
2190#
2191# Arguments:
2192#	option		The option to check.
2193#	default		The default value.  If any widget in the list
2194#			does not match this default, its value is used.
2195#	args		A list of widgets.
2196#
2197# Results:
2198#	Returns the value of the given option to use.
2199#
2200proc Widget::getOption { option default args } {
2201    for {set i [expr [llength $args] -1]} {$i >= 0} {incr i -1} {
2202	set widget [lindex $args $i]
2203	set value  [Widget::cget $widget $option]
2204	if {[string equal $value $default]} { continue }
2205	return $value
2206    }
2207    return $value
2208}
2209
2210
2211proc Widget::nextIndex { path node } {
2212    Widget::getVariable $path autoIndex
2213    if {![info exists autoIndex]} { set autoIndex -1 }
2214    return [string map [list #auto [incr autoIndex]] $node]
2215}
2216
2217
2218proc Widget::exists { path } {
2219    variable _class
2220    return [info exists _class($path)]
2221}
2222
2223proc Widget::theme {{bool {}}} {
2224    # Private, *experimental* API that may change at any time - JH
2225    variable _theme
2226    if {[llength [info level 0]] == 2} {
2227	# set theme-ability
2228	if {[catch {package require tile 0.6}]
2229	    && [catch {package require tile 1}]} {
2230	    return -code error "BWidget's theming requires tile 0.6+"
2231	} else {
2232	    catch {style default BWSlim.Toolbutton -padding 0}
2233	}
2234	set _theme [string is true -strict $bool]
2235    }
2236    return $_theme
2237}
2238
2239
2240namespace eval ProgressBar {
2241    Widget::define ProgressBar progressbar
2242
2243    Widget::declare ProgressBar {
2244        {-type        Enum       normal     0
2245                      {normal incremental infinite nonincremental_infinite}}
2246        {-maximum     Int        100        0 "%d > 0"}
2247        {-background  TkResource ""         0 frame}
2248        {-foreground  TkResource "blue"     0 label}
2249        {-borderwidth TkResource 2          0 frame}
2250        {-troughcolor TkResource ""         0 scrollbar}
2251        {-relief      TkResource sunken     0 label}
2252        {-orient      Enum       horizontal 1 {horizontal vertical}}
2253        {-variable    String     ""         0}
2254        {-idle        Boolean    0          0}
2255        {-width       TkResource 100        0 frame}
2256        {-height      TkResource 4m         0 frame}
2257        {-bg          Synonym    -background}
2258        {-fg          Synonym    -foreground}
2259        {-bd          Synonym    -borderwidth}
2260    }
2261
2262    Widget::addmap ProgressBar "" :cmd {-background {} -width {} -height {}}
2263    Widget::addmap ProgressBar "" .bar {
2264	-troughcolor -background -borderwidth {} -relief {}
2265    }
2266
2267    variable _widget
2268}
2269
2270
2271# ----------------------------------------------------------------------------
2272#  Command ProgressBar::create
2273# ----------------------------------------------------------------------------
2274proc ProgressBar::create { path args } {
2275    variable _widget
2276
2277    array set maps [list ProgressBar {} :cmd {} .bar {}]
2278    array set maps [Widget::parseArgs ProgressBar $args]
2279    eval frame $path $maps(:cmd) -class ProgressBar -bd 0 \
2280	    -highlightthickness 0 -relief flat
2281    Widget::initFromODB ProgressBar $path $maps(ProgressBar)
2282
2283    set c  [eval [list canvas $path.bar] $maps(.bar) -highlightthickness 0]
2284    set fg [Widget::cget $path -foreground]
2285    if { [string equal [Widget::cget $path -orient] "horizontal"] } {
2286        $path.bar create rectangle -1 0 0 0 -fill $fg -outline $fg -tags rect
2287    } else {
2288        $path.bar create rectangle 0 1 0 0 -fill $fg -outline $fg -tags rect
2289    }
2290
2291    set _widget($path,val) 0
2292    set _widget($path,dir) 1
2293    set _widget($path,var) [Widget::cget $path -variable]
2294    if {$_widget($path,var) != ""} {
2295        GlobalVar::tracevar variable $_widget($path,var) w \
2296		[list ProgressBar::_modify $path]
2297        set _widget($path,afterid) \
2298	    [after idle [list ProgressBar::_modify $path]]
2299    }
2300
2301    bind $path.bar <Destroy>   [list ProgressBar::_destroy $path]
2302    bind $path.bar <Configure> [list ProgressBar::_modify $path]
2303
2304    return [Widget::create ProgressBar $path]
2305}
2306
2307
2308# ----------------------------------------------------------------------------
2309#  Command ProgressBar::configure
2310# ----------------------------------------------------------------------------
2311proc ProgressBar::configure { path args } {
2312    variable _widget
2313
2314    set res [Widget::configure $path $args]
2315
2316    if { [Widget::hasChangedX $path -variable] } {
2317	set newv [Widget::cget $path -variable]
2318        if { $_widget($path,var) != "" } {
2319            GlobalVar::tracevar vdelete $_widget($path,var) w \
2320		    [list ProgressBar::_modify $path]
2321        }
2322        if { $newv != "" } {
2323            set _widget($path,var) $newv
2324            GlobalVar::tracevar variable $newv w \
2325		    [list ProgressBar::_modify $path]
2326	    if {![info exists _widget($path,afterid)]} {
2327		set _widget($path,afterid) \
2328		    [after idle [list ProgressBar::_modify $path]]
2329	    }
2330        } else {
2331            set _widget($path,var) ""
2332        }
2333    }
2334
2335    foreach {cbd cor cma} [Widget::hasChangedX $path -borderwidth \
2336	    -orient -maximum] break
2337
2338    if { $cbd || $cor || $cma } {
2339	if {![info exists _widget($path,afterid)]} {
2340	    set _widget($path,afterid) \
2341		[after idle [list ProgressBar::_modify $path]]
2342	}
2343    }
2344    if { [Widget::hasChangedX $path -foreground] } {
2345	set fg [Widget::cget $path -foreground]
2346        $path.bar itemconfigure rect -fill $fg -outline $fg
2347    }
2348    return $res
2349}
2350
2351
2352# ----------------------------------------------------------------------------
2353#  Command ProgressBar::cget
2354# ----------------------------------------------------------------------------
2355proc ProgressBar::cget { path option } {
2356    return [Widget::cget $path $option]
2357}
2358
2359
2360# ----------------------------------------------------------------------------
2361#  Command ProgressBar::_modify
2362# ----------------------------------------------------------------------------
2363proc ProgressBar::_modify { path args } {
2364    variable _widget
2365
2366    catch {unset _widget($path,afterid)}
2367    if { ![GlobalVar::exists $_widget($path,var)] ||
2368	 [set val [GlobalVar::getvar $_widget($path,var)]] < 0 } {
2369        catch {place forget $path.bar}
2370    } else {
2371	place $path.bar -relx 0 -rely 0 -relwidth 1 -relheight 1
2372	set type [Widget::getoption $path -type]
2373	if { $val != 0 && $type != "normal" && \
2374		$type != "nonincremental_infinite"} {
2375	    set val [expr {$val+$_widget($path,val)}]
2376	}
2377	set _widget($path,val) $val
2378	set max [Widget::getoption $path -maximum]
2379	set bd  [expr {2*[$path.bar cget -bd]}]
2380	set w   [winfo width  $path.bar]
2381	set h   [winfo height $path.bar]
2382	if {$type == "infinite" || $type == "nonincremental_infinite"} {
2383	    # JDC: New infinite behaviour
2384	    set tval [expr {$val % $max}]
2385	    if { $tval < ($max / 2.0) } {
2386		set x0 [expr {double($tval) / double($max) * 1.5}]
2387	    } else {
2388		set x0 [expr {(1.0-(double($tval) / double($max))) * 1.5}]
2389	    }
2390	    set x1 [expr {$x0 + 0.25}]
2391	    # convert coords to ints to prevent triggering canvas refresh
2392	    # bug related to fractional coords
2393	    if {[Widget::getoption $path -orient] == "horizontal"} {
2394		$path.bar coords rect [expr {int($x0*$w)}] 0 \
2395		    [expr {int($x1*$w)}] $h
2396	    } else {
2397		$path.bar coords rect 0 [expr {int($h-$x0*$h)}] $w \
2398		    [expr {int($x1*$h)}]
2399	    }
2400	} else {
2401	    if { $val > $max } {set val $max}
2402	    if {[Widget::getoption $path -orient] == "horizontal"} {
2403		$path.bar coords rect -1 0 [expr {int(double($val)*$w/$max)}] $h
2404	    } else {
2405		$path.bar coords rect 0 [expr {$h+1}] $w \
2406		    [expr {int($h*(1.0 - double($val)/$max))}]
2407	    }
2408	}
2409    }
2410    if {![Widget::cget $path -idle]} {
2411	update idletasks
2412    }
2413}
2414
2415
2416# ----------------------------------------------------------------------------
2417#  Command ProgressBar::_destroy
2418# ----------------------------------------------------------------------------
2419proc ProgressBar::_destroy { path } {
2420    variable _widget
2421
2422    if {[info exists _widget($path,afterid)]} {
2423	after cancel $_widget($path,afterid)
2424	unset _widget($path,afterid)
2425    }
2426    if {[info exists _widget($path,var)]} {
2427	if {$_widget($path,var) != ""} {
2428	    GlobalVar::tracevar vdelete $_widget($path,var) w \
2429		[list ProgressBar::_modify $path]
2430	}
2431	unset _widget($path,var)
2432    }
2433    unset _widget($path,dir)
2434    Widget::destroy $path
2435}
2436