1#  ttoolbar.tcl ---
2#
3#      This file is part of The Coccinella application.
4#      It implements a toolbar mega widget using tile.
5#
6#  Copyright (c) 2005-2006  Mats Bengtsson
7#
8#  This file is distributed under BSD style license.
9#
10# $Id: ttoolbar.tcl,v 1.22 2008-06-11 08:12:05 matben Exp $
11#
12# ########################### USAGE ############################################
13#
14#   NAME
15#      ttoolbar - toolbar megawidget.
16#
17#   SYNOPSIS
18#      ttoolbar pathName ?options?
19#
20#   OPTIONS
21#	-borderwidth, borderWidth, BorderWidth
22#	-padx, padX, PadX
23#	-pady, padY, PadY
24#	-relief, relief, Relief
25#	-takefocus, takeFocus, TakeFocus
26#
27#   WIDGET COMMANDS
28#      pathName buttonconfigure name
29#      pathName cget option
30#      pathName configure ?option? ?value option value ...?
31#      pathName exists name
32#      pathName minwidth
33#      pathName newbutton name ?-text str -image name -disabledimage name
34#                              -command cmd -balloontext str?
35#
36# ########################### CHANGES ##########################################
37#
38#       1.0     Original version
39
40package provide ttoolbar 1.0
41
42namespace eval ::ttoolbar {
43
44    namespace export ttoolbar
45
46}
47
48# ::ttoolbar::Init --
49#
50#       Contains initializations needed for the ttoolbar widget. It is
51#       only necessary to invoke it for the first instance of a widget since
52#       all stuff defined here are common for all widgets of this type.
53#
54# Arguments:
55#       none.
56#
57# Results:
58#       none.
59
60proc ::ttoolbar::Init { } {
61    global  tcl_platform
62
63    variable this
64    variable ttoolbarOptions
65    variable widgetOptions
66
67    if {[catch {package require balloonhelp}]} {
68	set this(balloonhelp) 0
69    } else {
70	set this(balloonhelp) 1
71    }
72
73    # Aqua gray arrows.
74    image create photo ::ttoolbar::open -data {
75	R0lGODlhCQAJAPMAMf///62trZycnJSUlIyMjISEhHNzcwAAAAAAAAAAAAAA
76	AAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAJAAkAAAQccJhJzZB1DlBy
77	AUCQBSBHfSVApSBhECxoxKCQRgA7
78    }
79    image create photo ::ttoolbar::close -data {
80	R0lGODlhCQAJAPMAMf///62trZycnJSUlIyMjISEhHNzcwAAAAAAAAAAAAAA
81	AAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAJAAkAAAQacAxAKzCmBHtx
82	tp5HUGEolMbYYQWYbZbEUREAOw==
83    }
84
85    foreach name [ttk::themes] {
86	if {[catch {package require ttk::theme::$name}]} {
87	    continue
88	}
89	ttk::style theme settings $name {
90
91	    # This produces fairly hard edged borders.
92	    ttk::style layout TToolbar.TButton {
93		TToolbar.border -children {
94		    TToolbar.padding -children {
95			TToolbar.label -side left
96		    }
97		}
98	    }
99	    ttk::style configure TToolbar.TButton   \
100	      -padding 2 -relief flat -borderwidth 1
101	    ttk::style map TToolbar.TButton -relief {
102		disabled flat
103		selected sunken
104		pressed  sunken
105		active   raised
106	    }
107        }
108    }
109
110    # List all allowed options with their database names and class names.
111    array set widgetOptions {
112	-collapsable         {collapsable          Collapsable         }
113	-compound            {compound             Compound            }
114	-ipadding            {ipadding             Ipadding            }
115	-packimagepadx       {packImagePadX        PackImagePadX       }
116	-packimagepady       {packImagePadY        PackImagePadY       }
117	-packtextpadx        {packTextPadX         PackTextPadX        }
118	-packtextpady        {packTextPadY         PackTextPadY        }
119	-padding             {padding              Padding             }
120	-showballoon         {showBalloon          ShowBalloon         }
121	-stylecollapse       {styleCollapse        StyleCollapse       }
122	-styleimage          {styleImage           StyleImage          }
123	-styletext           {styleText            StyleText           }
124    }
125
126    set ttoolbarOptions [array names widgetOptions]
127
128    option add *TToolbar.collapsable         0                widgetDefault
129    option add *TToolbar.compound            both             widgetDefault
130    option add *TToolbar.ipadding           {0}               widgetDefault
131    option add *TToolbar.padding            {4 4 6 4}         widgetDefault
132    option add *TToolbar.packImagePadX       4                widgetDefault
133    option add *TToolbar.packImagePadY       0                widgetDefault
134    option add *TToolbar.packTextPadX        0                widgetDefault
135    option add *TToolbar.packTextPadY        0                widgetDefault
136    option add *TToolbar.showBalloon         1                widgetDefault
137    option add *TToolbar.styleCollapse       TToolbar.TCheckbutton widgetDefault
138    option add *TToolbar.styleText           Toolbutton       widgetDefault
139    if {[tk windowingsyste] eq "win32"} {
140	option add *TToolbar.styleImage      Toolbutton       widgetDefault
141    } else {
142	option add *TToolbar.styleImage      TToolbar.TButton widgetDefault
143    }
144
145    variable widgetCommands {
146	buttonconfigure cget configure exists minwidth newbutton
147    }
148
149    # This allows us to clean up some things when we go away.
150    bind TToolbar <Destroy> {+::ttoolbar::DestroyHandler %W }
151
152    set this(inited) 1
153}
154
155# ttoolbar::ttoolbar --
156#
157#       Constructor for the ttoolbar mega widget.
158#
159# Arguments:
160#       w      the widget.
161#       args   list of '-name value' options.
162#
163# Results:
164#       The widget.
165
166proc ::ttoolbar::ttoolbar {w args} {
167
168    variable this
169    variable ttoolbarOptions
170    variable widgetOptions
171
172    # Perform a one time initialization.
173    if {![info exists this(inited)]} {
174	Init
175    }
176
177    # Instance specific namespace
178    namespace eval ::ttoolbar::${w} {
179	variable options
180	variable widgets
181	variable locals
182    }
183
184    # Set simpler variable names.
185    upvar ::ttoolbar::${w}::options options
186    upvar ::ttoolbar::${w}::widgets widgets
187    upvar ::ttoolbar::${w}::locals locals
188
189    # We use a frame for this specific widget class.
190    set widgets(this)   [ttk::frame $w -class TToolbar]
191    set widgets(frame)  ::ttoolbar::${w}::${w}
192    set widgets(iframe) $w.f
193    set widgets(arrow)  $w.arrow
194
195    ttk::frame $w.f
196
197    # Padding to make all flush left.
198    ttk::frame $w.f.pad
199    grid  $w.f.pad  -column 99 -row 0 -sticky ew
200    grid columnconfigure $w.f 99 -weight 1
201
202    # Parse options for the widget. First get widget defaults.
203    foreach name $ttoolbarOptions {
204	set optName  [lindex $widgetOptions($name) 0]
205	set optClass [lindex $widgetOptions($name) 1]
206	set options($name) [option get $w $optName $optClass]
207    }
208
209    # Apply the options supplied in the widget command.
210    # Overwrites defaults when option set in command.
211    if {[llength $args]} {
212	eval {Configure $w} $args
213    }
214    set locals(uid) 0
215
216    if {$options(-collapsable)} {
217	set locals(collapse) 0
218	ttk::checkbutton $widgets(arrow) -style $options(-stylecollapse) \
219	  -command [list ::ttoolbar::CollapseCmd $w] \
220	  -variable ::ttoolbar::${w}::locals(collapse)
221	pack $w.arrow -side left -anchor n
222	bind $w       <<ButtonPopup>> [list ::ttoolbar::Popup $w %x %y]
223	bind $w.f     <<ButtonPopup>> [list ::ttoolbar::Popup $w %x %y]
224	bind $w.f.pad <<ButtonPopup>> [list ::ttoolbar::Popup $w %x %y]
225	bind $w.arrow <<ButtonPopup>> [list ::ttoolbar::Popup $w %x %y]
226    }
227    pack $w.f -fill both -expand 1
228
229    # Necessary to remove the original frame procedure from the global
230    # namespace into our own.
231    rename ::$w $widgets(frame)
232
233    # Create the actual widget procedure.
234    proc ::${w} {command args}   \
235      "eval ::ttoolbar::WidgetProc {$w} \$command \$args"
236
237    return $w
238}
239
240# ::ttoolbar::WidgetProc --
241#
242#       This implements the methods, cget, configure etc.
243#
244# Arguments:
245#       w       the widget path.
246#       command the actual command; cget, configure etc.
247#       args    list of key value pairs for the widget options.
248# Results:
249#
250
251proc ::ttoolbar::WidgetProc {w command args} {
252
253    variable widgetCommands
254    upvar ::ttoolbar::${w}::options options
255    upvar ::ttoolbar::${w}::locals locals
256
257    set result ""
258
259    # Which command?
260    switch -- $command {
261	buttonconfigure {
262	    set result [eval {ButtonConfigure $w} $args]
263	}
264	cget {
265	    if {[llength $args] != 1} {
266		return -code error "wrong # args: should be $w cget option"
267	    }
268	    set result $options($args)
269	}
270	collapse {
271	    if {[llength $args] == 0} {
272		return $locals(collapse)
273	    } elseif {[llength $args] == 1} {
274		set locals(collapse) $args
275		CollapseCmd $w
276	    } else {
277		return -code error "wrong # args: should be $w collapse ?0|1?"
278	    }
279	}
280	configure {
281	    set result [eval {Configure $w} $args]
282	}
283	exists {
284	    set name [lindex $args 0]
285	    set result [info exists locals($name,-state)]
286	}
287	iscollapsed {
288	    if {[llength $args]} {
289		return -code error "wrong # args: should be $w iscollapsed"
290	    }
291	    set result $locals(collapse)
292	}
293	minwidth {
294	    set result [MinWidth $w]
295	}
296	newbutton {
297	    set result [eval {NewButton $w} $args]
298	}
299	default {
300	    return -code error "unknown command \"$command\" of the ttoolbar widget.\
301	      Must be one of $widgetCommands"
302	}
303    }
304    return $result
305}
306
307# ::ttoolbar::Configure --
308#
309#       Implements the "configure" widget command (method).
310#
311# Arguments:
312#       w       the widget path.
313#       args    list of key value pairs for the widget options.
314# Results:
315#
316
317proc ::ttoolbar::Configure {w args} {
318
319    variable this
320    variable widgetOptions
321    upvar ::ttoolbar::${w}::options options
322    upvar ::ttoolbar::${w}::widgets widgets
323    upvar ::ttoolbar::${w}::locals  locals
324
325    # Error checking.
326    foreach {name value} $args  {
327	if {![info exists widgetOptions($name)]}  {
328	    return -code error "unknown option for the ttoolbar: $name"
329	}
330    }
331    if {[llength $args] == 0}  {
332
333	# Return all options.
334	foreach opt [lsort [array names widgetOptions]] {
335	    set optName  [lindex $widgetOptions($opt) 0]
336	    set optClass [lindex $widgetOptions($opt) 1]
337	    set def      [option get $w $optName $optClass]
338	    lappend results [list $opt $optName $optClass $def $options($opt)]
339	}
340	return $results
341    } elseif {[llength $args] == 1}  {
342
343	# Return configuration value for this option.
344	set opt $args
345	set optName  [lindex $widgetOptions($opt) 0]
346	set optClass [lindex $widgetOptions($opt) 1]
347	set def      [option get $w $optName $optClass]
348	return [list $opt $optName $optClass $def $options($opt)]
349    }
350
351    # Error checking.
352    if {[expr {[llength $args]%2}] == 1}  {
353	return -code error "value for \"[lindex $args end]\" missing"
354    }
355    array set saveOpts [array get options]
356    array set options $args
357
358    set f $widgets(iframe)
359    $f configure -padding $options(-ipadding)
360
361    # Process the new configuration options.
362    set ncol [llength [array names locals *,-text]]
363    if {$ncol && ($saveOpts(-compound) ne $options(-compound))} {
364	set wtexts [lsearch -glob -inline -all [winfo children $f] $f.t*]
365	set wimages [lsearch -glob -inline -all [winfo children $f] $f.i*]
366
367	switch -- $options(-compound) {
368	    both {
369		set mapimage 1
370		set maptext  1
371	    }
372	    image {
373		set mapimage 1
374		set maptext  0
375	    }
376	    text {
377		set mapimage 0
378		set maptext  1
379	    }
380	}
381	if {$maptext} {
382	    set ncol 0
383	    foreach wtext $wtexts {
384		grid  $wtext  -column $ncol -row 1 \
385		  -padx $options(-packtextpadx) -pady $options(-packtextpady)
386		incr ncol
387	    }
388	} else {
389	    eval {grid forget} $wtexts
390	}
391	if {$mapimage} {
392	    set ncol 0
393	    foreach wimage $wimages {
394		grid  $wimage  -column $ncol -row 0 \
395		  -padx $options(-packimagepadx) -pady $options(-packimagepady)
396		incr ncol
397	    }
398	} else {
399	    eval {grid forget} $wimages
400	}
401	if {$this(balloonhelp) && $options(-showballoon)} {
402	    if {$options(-compound) eq "image"} {
403		foreach {key name} [array get locals *,name] {
404		    ::balloonhelp::balloonforwindow $widgets($name,image) \
405		      $locals($name,-text)
406		}
407	    } else {
408		foreach wimage $wimages {
409		    ::balloonhelp::delete $wimage
410		}
411	    }
412	}
413	if {$this(balloonhelp)} {
414	    foreach {key name} [array get locals *,name] {
415		if {[info exists locals($name,-balloontext)]} {
416		    set wimage $widgets($name,image)
417		    ::balloonhelp::delete $wimage
418		    ::balloonhelp::balloonforwindow $wimage \
419		      $locals($name,-balloontext)
420		}
421	    }
422	}
423	event generate $w <<TToolbarCompound>>
424    }
425}
426
427proc ::ttoolbar::CollapseCmd {w} {
428
429    upvar ::ttoolbar::${w}::widgets widgets
430    upvar ::ttoolbar::${w}::locals locals
431
432    set f $widgets(iframe)
433    if {$locals(collapse)} {
434	pack forget $f
435    } else {
436	pack $f -fill both -expand 1
437    }
438    event generate $w <<TToolbarCollapse>>
439}
440
441proc ::ttoolbar::Popup {w x y} {
442
443    upvar ::ttoolbar::${w}::options options
444
445    set m $w.m
446    destroy $m
447    menu $m -tearoff 0
448
449    set [namespace current]::menutmp $options(-compound)
450
451    # TRANSLATORS; right-click menu of the toolbars
452    $m add radiobutton -label [::msgcat::mc "Show Text and Icon"] \
453      -command [list $w configure -compound both] \
454      -variable [namespace current]::menutmp  \
455      -value both
456    $m add radiobutton -label [::msgcat::mc "Show Text"] \
457      -command [list $w configure -compound text] \
458      -variable [namespace current]::menutmp  \
459      -value text
460    $m add radiobutton -label [::msgcat::mc "Show Icon"] \
461      -command [list $w configure -compound image] \
462      -variable [namespace current]::menutmp  \
463      -value image
464
465    update idletasks
466
467    set X [expr {[winfo rootx $w] + $x}]
468    set Y [expr {[winfo rooty $w] + $y}]
469    tk_popup $m [expr {int($X) - 0}] [expr {int($Y) - 0}]
470
471    return -code break
472}
473
474proc ::ttoolbar::NewButton {w name args} {
475
476    upvar ::ttoolbar::${w}::options options
477    upvar ::ttoolbar::${w}::widgets widgets
478    upvar ::ttoolbar::${w}::locals  locals
479
480    set ncol [llength [array names locals *,-text]]
481
482    set locals($name,name)            $name
483    set locals($name,-text)           $name
484    set locals($name,-command)        ""
485    set locals($name,-state)          normal
486    set locals($name,-image)          ""
487    set locals($name,-disabledimage)  ""
488
489    set f $widgets(iframe)
490    set uid $locals(uid)
491    set wimage $f.i$uid
492    set wtext  $f.t$uid
493    set locals($name,uid)    $locals(uid)
494    set widgets($name,image) $wimage
495    set widgets($name,text)  $wtext
496
497    set cmd [list [namespace current]::Invoke $w $name]
498    ttk::button $wimage -style $options(-styleimage) -command $cmd  \
499      -compound image
500    ttk::button $wtext  -style $options(-styletext)  -command $cmd  \
501      -compound text
502
503    switch -- $options(-compound) {
504	both {
505	    set mapimage 1
506	    set maptext  1
507	}
508	image {
509	    set mapimage 1
510	    set maptext  0
511	}
512	text {
513	    set mapimage 0
514	    set maptext  1
515	}
516    }
517    if {$mapimage} {
518	grid  $wimage  -column $ncol -row 0 \
519	  -padx $options(-packimagepadx) -pady $options(-packimagepady)
520    }
521    if {$maptext} {
522	grid  $wtext  -column $ncol -row 1 \
523	  -padx $options(-packtextpadx) -pady $options(-packtextpady)
524    }
525    eval {ButtonConfigure $w $name} $args
526
527    incr locals(uid)
528}
529
530proc ::ttoolbar::Invoke {w name} {
531
532    upvar ::ttoolbar::${w}::locals locals
533
534    uplevel #0 $locals($name,-command)
535}
536
537proc ::ttoolbar::ButtonConfigure {w name args} {
538    variable this
539    upvar ::ttoolbar::${w}::options options
540    upvar ::ttoolbar::${w}::widgets widgets
541    upvar ::ttoolbar::${w}::locals  locals
542
543    if {![info exists locals($name,-state)]} {
544	return -code error "button \"$name\" does not exist in $w"
545    }
546    set wimage $widgets($name,image)
547    set wtext  $widgets($name,text)
548
549    foreach {key value} $args {
550	set flags($key) 1
551
552	switch -- $key {
553	    -command - -disabledimage - -image - -state {
554		set locals($name,$key) $value
555	    }
556	    -text {
557		set locals($name,-text) $value
558		$wtext configure -text $value
559
560		if {$this(balloonhelp) && $options(-showballoon)} {
561		    if {![info exists haveBalloon] && ($options(-compound) eq "image")} {
562			::balloonhelp::delete $wimage
563			::balloonhelp::balloonforwindow $wimage $value
564		    }
565		}
566	    }
567	    -balloontext {
568		if {$this(balloonhelp)} {
569		    set locals($name,$key) $value
570		    ::balloonhelp::delete $wimage
571		    ::balloonhelp::balloonforwindow $wimage $value
572		    set haveBalloon 1
573		}
574	    }
575	}
576    }
577    if {[info exists flags(-image)] || [info exists flags(-disabledimage)]} {
578	set imName    $locals($name,-image)
579	set imNameDis $locals($name,-disabledimage)
580	if {$imName != ""} {
581	    set imSpec $imName
582	    if {$imNameDis != ""} {
583		lappend imSpec disabled $imNameDis background $imNameDis
584	    }
585	    $wimage configure -image $imSpec
586	}
587    }
588    if {[info exists flags(-state)]} {
589	if {[string equal $locals($name,-state) "normal"]} {
590	    $wimage state {!disabled}
591	    $wtext  state {!disabled}
592	} else {
593	    $wimage state {disabled}
594	    $wtext  state {disabled}
595	}
596    }
597}
598
599proc ::ttoolbar::GetPaddingWidth {padding} {
600
601    switch -- [llength $padding] {
602	0 {
603	    set width 0
604	}
605	1 {
606	    set width [expr {2*$padding}]
607	}
608	2 {
609	    set width [expr {2*[lindex $padding 0]}]
610	}
611	4 {
612	    set width [expr {[lindex $padding 0] + [lindex $padding 2]}]
613	}
614    }
615    return $width
616}
617
618# ttoolbar::MinWidth --
619#
620#       Returns the width of all buttons created in the shortcut button pad.
621
622proc ::ttoolbar::MinWidth {w} {
623
624    upvar ::ttoolbar::${w}::options options
625    upvar ::ttoolbar::${w}::widgets widgets
626
627    set width [GetPaddingWidth $options(-padding)]
628    incr width [GetPaddingWidth $options(-ipadding)]
629    if {[winfo exists $widgets(arrow)]} {
630	incr width [winfo width $widgets(arrow)]
631    }
632    foreach {key wtext} [array get widgets *,text] {
633	array set gridInfo [grid info $wtext]
634	if {[info exists gridInfo(-padx)]} {
635	    incr width [expr {2*$gridInfo(-padx)}]
636	    incr width [winfo reqwidth $wtext]
637	}
638    }
639    return $width
640}
641
642# ttoolbar::DestroyHandler --
643#
644#       The exit handler of a ttoolbar.
645#
646# Arguments:
647#       w       the widget path.
648#
649# Results:
650#       the internal state is cleaned up, namespace deleted.
651
652proc ::ttoolbar::DestroyHandler {w} {
653
654    # Remove the namespace with the widget.
655    if {[string equal [winfo class $w] "TToolbar"]} {
656	namespace delete ::ttoolbar::${w}
657    }
658}
659
660#-------------------------------------------------------------------------------
661
662
663