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