1# tipstack.tcl --
2#
3#	Based on 'tooltip', provides a dynamic stack of tip texts per
4#	widget. This allows dynamic transient changes to the tips, for
5#	example to temporarily replace a standard epxlanation with an
6#	error message.
7#
8# Copyright (c) 2003 ActiveState Corporation.
9#
10# See the file "license.terms" for information on usage and
11# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12#
13# RCS: @(#) $Id: tipstack.tcl,v 1.4 2009/01/09 05:46:12 andreas_kupries Exp $
14#
15
16# ### ######### ###########################
17# Requisites
18
19package require tooltip
20namespace eval ::tipstack {}
21
22# ### ######### ###########################
23# Public API
24#
25## Basic syntax for all commands having a widget reference:
26#
27## tipstack::command .w ...
28## tipstack::command .m -index foo ...
29
30# ### ######### ###########################
31## Push new text for a widget (or menu)
32
33proc ::tipstack::push {args} {
34    if {([llength $args] != 2) && (([llength $args] != 4))} {
35	return -code error "wrong#args: expected w ?-index index? text"
36    }
37
38    # Extract valueable parts.
39
40    set text [lindex $args end]
41    set wref [lrange $args 0 end-1]
42
43    # Remember new data (setup/extend db)
44
45    variable db
46    if {![info exists db($wref)]} {
47	set db($wref) [list $text]
48    } else {
49	lappend db($wref) $text
50    }
51
52    # Forward to standard tooltip package.
53
54    eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
55    return
56}
57
58# ### ######### ###########################
59## Pop text from stack of tip for widget.
60## ! Keeps the bottom-most entry.
61
62proc ::tipstack::pop {args} {
63    if {([llength $args] != 1) && (([llength $args] != 3))} {
64	return -code error "wrong#args: expected w ?-index index?"
65    }
66    # args == wref (see 'push').
67    set wref $args
68
69    # Pop top information form the database. Except if the
70    # text is the last in the stack. Then we will keep it, it
71    # is the baseline for the widget.
72
73    variable db
74    if {![info exists db($wref)]} {
75	set text ""
76    } else {
77	set data $db($wref)
78
79	if {[llength $data] == 1} {
80	    set text [lindex $data 0]
81	} else {
82	    set data [lrange $data 0 end-1]
83	    set text [lindex $data end]
84
85	    set db($wref) $data
86	}
87    }
88
89    # Forward to standard tooltip package.
90
91    eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
92    return
93}
94
95# ### ######### ###########################
96## Clears out all data about a widget (or menu).
97
98proc ::tipstack::clear {args} {
99
100    if {([llength $args] != 1) && (([llength $args] != 3))} {
101	return -code error "wrong#args: expected w ?-index index?"
102    }
103    # args == wref (see 'push').
104    set wref $args
105
106    # Remove data about widget.
107
108    variable db
109    catch {unset db($wref)}
110
111    eval [linsert [linsert $wref end ""] 0 tooltip::tooltip]
112    return
113}
114
115# ### ######### ###########################
116## Convenient definition of tooltips for multiple
117## independent widgets. No menus possible
118
119proc ::tipstack::def {defs} {
120    foreach {path text} $defs {
121	push $path $text
122    }
123    return
124}
125
126# ### ######### ###########################
127## Convenient definition of tooltips for multiple
128## widgets in a containing widget. No menus possible.
129## This is for megawidgets.
130
131proc ::tipstack::defsub {base defs} {
132    foreach {subpath text} $defs {
133	push $base$subpath $text
134    }
135    return
136}
137
138# ### ######### ###########################
139## Convenient clearage of tooltips for multiple
140## widgets in a containing widget. No menus possible.
141## This is for megawidgets.
142
143proc ::tipstack::clearsub {base} {
144    variable db
145
146    foreach k [array names db ${base}*] {
147	# Danger. Will fail if 'base' matches a menu reference.
148	clear $k
149    }
150    return
151}
152
153# ### ######### ###########################
154# Internal commands -- None
155
156# ### ######### ###########################
157## Data structures
158
159namespace eval ::tipstack {
160    # Map from widget references to stack of tooltips.
161
162    variable  db
163    array set db {}
164}
165
166# ### ######### ###########################
167# Ready
168
169package provide tipstack 1.0.1
170