Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | initial import of widget package into tcllib repository |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
9638cf7a81e7ce1473af70003aa1daa9 |
User & Date: | hobbs 2001-06-25 23:05:50.000 |
Context
2001-06-26
| ||
00:39 | * library/calculator.tcl: * library/console.tcl: * library/hierarchy.tcl: * library/megalist.tcl: * library/pane.tcl: * library/progressbar.tcl: * library/util-color.tcl: * library/util.tcl: * library/ventry.tcl: corrected code that procheck complained about * library/util-find.tcl: * library/util-list.tcl: removed - they weren't ready yet check-in: 59bcef3c64 user: hobbs tags: trunk | |
2001-06-25
| ||
23:05 | initial import of widget package into tcllib repository check-in: 9638cf7a81 user: hobbs tags: trunk | |
23:05 | initial empty check-in check-in: 51780a4330 user: root tags: trunk | |
Changes
Added ChangeLog.
> > > > | 1 2 3 4 | 2001-06-25 Jeff Hobbs <[email protected]> * initial import of widget code into tcllib repository |
Added LICENSE.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | * COPYRIGHT AND LICENSE TERMS * (This file blatantly stolen from Tcl/Tk license and adapted - thus assume it falls under similar license terms). This software is copyrighted by Jeffrey Hobbs <[email protected]>. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. RESTRICTED RIGHTS: Use, duplication or disclosure by the U.S. government is subject to the restrictions as set forth in subparagraph (c) (1) (ii) of the Rights in Technical Data and Computer Software Clause as DFARS 252.227-7013 and FAR 52.227-19. SPECIAL NOTES: This software is also falls under the bourbon_ware clause: Should you find this software useful in your daily work, you should feel obliged to take the author out for a drink if the opportunity presents itself. The user may feel exempt from this clause if they are under 21 or think the author has already partaken of too many drinks. |
Added demo/TOUR.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 | #!/bin/sh # The next line is executed by /bin/sh, but not tcl \ exec wish $0 ${1+"$@"} # tour -- # # Tour of the megawidget of package ::Widget # # Copyright (c) 1997 Jeffrey Hobbs # package require Tk if {![info exists TOUR(LOADED)]} { set TOUR(SCRIPT) [info script] foreach dir [list \ [file join [file dirname $TOUR(SCRIPT)] .. library] \ ] { if {[lsearch -exact $auto_path $dir]==-1} { lappend auto_path $dir } } if {[string compare unix $tcl_platform(platform)]} { # get rid of the console on windows/mac catch {rename console winconsole} } set TOUR(LOADED) 0 } ## AllWidgets will end up including: # Widget # ::Utility # ::Utility::dump # ::Utility::string # ::Utility::number # ::Utility::tk # ::Utility::expand # BalloonHelp # Calculator # Combobox # Console # Hierarchy # Megalist # Pane # Progressbar # Tabnotebook # Ventry package require AllWidgets destroy .tab .exit tabnotebook .tab button .exit -text "Exit" -command exit namespace import -force ::Utility::* grid .tab -sticky news grid .exit -sticky ew grid rowconfigure . 0 -weight 1 grid columnconfig . 0 -weight 1 foreach n { Main Combobox Console Hierarchy Megalist Progressbar Ventry Script } { set TOUR($n) [frame .tab.[string tolower $n]] .tab add $n -window $TOUR($n) } .tab activate Main # get_comments -- # # Gets the major comments out of a file. If not a real filename, # assume it is a package name that has a particular ifneeded setup. # # Arguments: # file file to get comments out of. # Results: # Returns the related comments. # proc get_comments {file} { if {![file exists $file]} { set version [package provide $file] if {[string match {} $version]} { return "## No Comments Found" } set loadstr [package ifneeded $file $version] if {[string match tclPkgSetup* $loadstr]} { set file [lindex [lindex [lindex $loadstr 4] 0] 0] } else { # this expects 8.1 regexps regexp {(\w+.tcl)} $loadstr file } if {![file exists $file]} { return "## Couldn't determine file for package '$file'" } } set fid [open $file] set comments {} set last 0 while {[gets $fid line] != -1} { if {[string match "##*" $line]} { append comments $line\n set last 1 } elseif {$last} { append comments \n set last 0 } } return $comments } ## Main Tab ## set f $TOUR(Main) pack [scrolledtext $f.t] -fill both -expand 1 $f.t insert 1.0 "Welcome to the widget tour. In the above tabs you will find basic examples with small feature descriptions of the various widgets in this package. This tour itself uses the Tabnotebook widget as the basic container for the widget tour. " ## Combobox Tab ## set f $TOUR(Combobox) scrolledtext $f.t -height 5 set w [frame $f.p] combobox $w.c1 -labeltext "Basic Combobox: " combobox $w.c2 -labeltext "Windows-like Combobox:" \ -width 15 -textvariable myvar -click single \ -list {{first choice} {second} {another choice} {final choice}} if {[string compare windows $tcl_platform(platform)]} { $w.c2 configure -bg white -selectforeground blue } label $w.l -text "Value:" label $w.myvar -textvariable myvar grid $w.c1 - - -sticky ew grid $w.c2 $w.l $w.myvar -sticky ew grid columnconfig $w 0 -weight 1 pane $f.t $f.p -orient vertical -dynamic yes $f.t insert 1.0 "Combobox class widget. The combobox emulates the Tix widget of the same name. Major comments for class: [get_comments Combobox] " ## Console Tab ## set f $TOUR(Console) pack [scrolledtext $f.t -height 5] -fill x pack [console $f.c -height 10] -fill both -expand 1 pane $f.t $f.c -orient vertical $f.t insert 1.0 "Console class widget. This is an interactive console for Tcl/Tk derived from TkCon. It presents an interactive window into the interpreter, with many features to assist in interactive debugging. Major comments for class: [get_comments Console] " ## Hierarchy Tab ## set f $TOUR(Hierarchy) scrolledtext $f.t -height 5 frame $f.p set TOUR(Hierarchy,w) [hierarchy_widget $f.p.w -root .] set TOUR(Hierarchy,d) [hierarchy_dir $f.p.d -root [file dirname [pwd]] \ -showparent "Parent" -showfiles 1] pane $f.t $f.p -orient vertical pane $f.p.w $f.p.d -dynamic 1 $f.t insert 1.0 "Paned window management and the Hierarchy class widgets. The hierarchy widgets displayed are for widget and file touring. Major comments for class Hierarchy: [get_comments Hierarchy] " ## Megalist Tab ## set f $TOUR(Megalist) pack [scrolledtext $f.t -height 5] -fill x $f.t insert 1.0 "Major comments for class Megalist: [get_comments Megalist] " ## Progressbar Tab ## set f $TOUR(Progressbar) pack [scrolledtext $f.t -height 5] -fill x pack [progressbar $f.p0 -labelt "Progress Bar" -variable ::P(0)] -side bottom pack [progressbar $f.p1 -labelt "Slow" -orient v -variable ::P(1)] -side left pack [progressbar $f.p2 -labelt "Fast" -orient v -variable ::P(2)] -side left $f.t insert 1.0 "Major comments for class Progressbar: [get_comments Progressbar] " # self-rescheduling incr proc for progressbars proc increase {varname {val 10} {delay 600}} { upvar $varname var set var [expr {($var+$val)%100}] after $delay [info level 0] } array set ::P {0 0 1 0 2 0 3 0} increase ::P(0) increase ::P(1) 1 increase ::P(2) 5 150 ## Ventry Tab ## set f $TOUR(Ventry) pack [scrolledtext $f.t -height 5] -fill x pack [ventry $f.v1 -labeltext "Integers:" -labelwidth 14 -validate key \ -vcmd {regexp {^[-+]?[0-9]*$} %P}] -fill x pack [ventry $f.v2 -labeltext "Max 8 chars:" -labelwidth 14 -validate key \ -vcmd {expr {[string length %P]<=8}}] -fill x pack [ventry $f.v3 -labeltext "Date on focus:" -labelwidth 14 \ -validate focusout -validatecmd {check_date %W %s} \ -invalidcmd {warn "Invalid Date specified"}] -fill x proc check_date {w date} { if {[string match {} $date]} { return 1 } $w delete 0 end set code [validate date $date] if {$code} { $w insert 0 [clock format [clock scan $date]] } else { focus -force [$w subwidget entry] } return $code } $f.t insert 1.0 "Ventry class widget. Major comments for class: [get_comments Ventry] " ## Script Tab ## set f $TOUR(Script) scrolledtext $f.t -wrap none button $f.rerun -text "Rerun Buffer" -command rerun button $f.reload -text "Reload Script" -command {reload 1} grid $f.t - grid $f.rerun $f.reload grid rowconfig $f 0 -weight 1 grid columnconfig $f 0 -weight 1 grid columnconfig $f 1 -weight 1 proc reload {{force 0}} { global TOUR set text $TOUR(Script).t $text delete 1.0 end if {$force || !$TOUR(LOADED)} { if {[catch {open $TOUR(SCRIPT)} fid]} { $text insert 1.0 $fid } else { $text insert 1.0 [read $fid] close $fid } } else { $text insert 1.0 $TOUR(BUFFER) } set TOUR(BUFFER) [$text get 1.0 end-1c] } proc rerun {} { global TOUR ## Get data from text widget set TOUR(BUFFER) [$TOUR(Script).t get 1.0 end-1c] uplevel \#0 $TOUR(BUFFER) } reload ## Balloon Help ## balloonhelp clear balloonhelp .exit "The Exit Button" balloonhelp $TOUR(Hierarchy,w) "Widget hierarchy" balloonhelp $TOUR(Hierarchy,d) "Directory hierarchy" set TOUR(LOADED) 1 |
Added library/balloonhelp.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | ## ## Copyright 1996-8 Jeffrey Hobbs, [email protected] ## ## Initiated: 28 October 1996 ## package provide BalloonHelp 2.0 ##------------------------------------------------------------------------ ## PROCEDURE ## balloonhelp ## ## DESCRIPTION ## Implements a balloon help system ## ## ARGUMENTS ## balloonhelp <option> ?arg? ## ## clear ?pattern? ## Stops the specified widgets (defaults to all) from showing balloon ## help. ## ## delay ?millisecs? ## Query or set the delay. The delay is in milliseconds and must ## be at least 50. Returns the delay. ## ## disable OR off ## Disables all balloon help. ## ## enable OR on ## Enables balloon help for defined widgets. ## ## <widget> ?-index index? ?message? ## If -index is specified, then <widget> is assumed to be a menu ## and the index represents what index into the menu (either the ## numerical index or the label) to associate the balloon help ## message with. Balloon help does not appear for disabled menu items. ## If message is {}, then the balloon help for that ## widget is removed. The widget must exist prior to calling ## balloonhelp. The current balloon help message for <widget> is ## returned, if any. ## ## RETURNS: varies (see methods above) ## ## NAMESPACE & STATE ## The global array BalloonHelp is used. Procs begin with BalloonHelp. ## The overrideredirected toplevel is named $BalloonHelp(TOPLEVEL). ## ## EXAMPLE USAGE: ## balloonhelp .button "A Button" ## balloonhelp .menu -index "Load" "Loads a file" ## ##------------------------------------------------------------------------ namespace eval ::Widget::BalloonHelp {; namespace export -clear balloonhelp variable BalloonHelp ## The extra :hide call in <Enter> is necessary to catch moving to ## child widgets where the <Leave> event won't be generated bind Balloons <Enter> [namespace code { #BalloonHelp:hide variable BalloonHelp set BalloonHelp(LAST) -1 if {$BalloonHelp(enabled) && [info exists BalloonHelp(%W)]} { set BalloonHelp(AFTERID) [after $BalloonHelp(DELAY) \ [namespace code [list show %W $BalloonHelp(%W)]]] } }] bind Menu <<MenuSelect>> [namespace code { menuMotion %W }] bind Balloons <Leave> [namespace code hide] bind Balloons <Any-KeyPress> [namespace code hide] bind Balloons <Any-Button> [namespace code hide] array set BalloonHelp { enabled 1 DELAY 500 AFTERID {} LAST -1 TOPLEVEL .__balloonhelp__ } proc balloonhelp {w args} { variable BalloonHelp switch -- $w { clear { if {[llength $args]==0} { set args .* } clear $args } delay { if {[llength $args]} { if {![regexp {^[0-9]+$} $args] || $args<50} { return -code error "BalloonHelp delay must be an\ integer greater than 50 (delay is in millisecs)" } return [set BalloonHelp(DELAY) $args] } else { return $BalloonHelp(DELAY) } } off - disable { set BalloonHelp(enabled) 0 hide } on - enable { set BalloonHelp(enabled) 1 } default { set i $w if {[llength $args]} { set i [uplevel 1 [namespace code "register [list $w] $args"]] } set b $BalloonHelp(TOPLEVEL) if {![winfo exists $b]} { toplevel $b wm overrideredirect $b 1 wm positionfrom $b program wm withdraw $b pack [label $b.l -highlightthickness 0 -relief raised -bd 1 \ -background lightyellow -fg black] } if {[info exists BalloonHelp($i)]} { return $BalloonHelp($i) } } } } ;proc register {w args} { variable BalloonHelp set key [lindex $args 0] while {[string match -* $key]} { switch -- $key { -index { if {[catch {$w entrycget 1 -label}]} { return -code error "widget \"$w\" does not seem to be a\ menu, which is required for the -index switch" } set index [lindex $args 1] set args [lreplace $args 0 1] } default { return -code error "unknown option \"$key\": should be -index" } } set key [lindex $args 0] } if {[llength $args] != 1} { return -code error "wrong \# args: should be \"balloonhelp widget\ ?-index index? message\"" } if {[string match {} $key]} { clear $w } else { if {![winfo exists $w]} { return -code error "bad window path name \"$w\"" } if {[info exists index]} { set BalloonHelp($w,$index) $key #bindtags $w [linsert [bindtags $w] end BalloonsMenu] return $w,$index } else { set BalloonHelp($w) $key bindtags $w [linsert [bindtags $w] end Balloons] return $w } } } ;proc clear {{pattern .*}} { variable BalloonHelp foreach w [array names BalloonHelp $pattern] { unset BalloonHelp($w) if {[winfo exists $w]} { set tags [bindtags $w] if {[set i [lsearch $tags Balloons]] != -1} { bindtags $w [lreplace $tags $i $i] } ## We don't remove BalloonsMenu because there ## might be other indices that use it } } } ;proc show {w msg {i {}}} { ## Use string match to allow that the help will be shown when ## the pointer is in any child of the desired widget if {![winfo exists $w] || ![string match \ $w* [eval winfo containing [winfo pointerxy $w]]]} return variable BalloonHelp global tcl_platform set b $BalloonHelp(TOPLEVEL) $b.l configure -text $msg update idletasks if {[string compare {} $i]} { set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}] if {($y+[winfo reqheight $b])>[winfo screenheight $w]} { set y [expr {[winfo rooty $w]+[$w yposition $i]-\ [winfo reqheight $b]-5}] } } else { set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}] if {($y+[winfo reqheight $b])>[winfo screenheight $w]} { set y [expr {[winfo rooty $w]-[winfo reqheight $b]-5}] } } set x [expr {[winfo rootx $w]+[winfo vrootx $w]+\ ([winfo width $w]-[winfo reqwidth $b])/2}] if {$x<0} { set x 0 } elseif {($x+[winfo reqwidth $b])>[winfo screenwidth $w]} { set x [expr {[winfo screenwidth $w]-[winfo reqwidth $b]}] } wm geometry $b +$x+$y if {[string match windows $tcl_platform(platform)]} { ## Yes, this is only needed on Windows update idletasks } wm deiconify $b raise $b } ;proc menuMotion {w} { variable BalloonHelp if {$BalloonHelp(enabled)} { set cur [$w index active] ## The next two lines (all uses of LAST) are necessary until the ## <<MenuSelect>> event is properly coded for Unix/(Windows)? if {$cur == $BalloonHelp(LAST)} return set BalloonHelp(LAST) $cur ## a little inlining - this is :hide after cancel $BalloonHelp(AFTERID) catch {wm withdraw $BalloonHelp(TOPLEVEL)} if {[info exists BalloonHelp($w,$cur)] || \ (![catch {$w entrycget $cur -label} cur] && \ [info exists BalloonHelp($w,$cur)])} { set BalloonHelp(AFTERID) [after $BalloonHelp(DELAY) \ [namespace code [list show $w $BalloonHelp($w,$cur) $cur]]] } } } ;proc hide {args} { variable BalloonHelp after cancel $BalloonHelp(AFTERID) catch {wm withdraw $BalloonHelp(TOPLEVEL)} } }; # end namespace ::Widget::BalloonHelp namespace eval :: {namespace import -force ::Widget::BalloonHelp::balloonhelp} |
Added library/calculator.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | ## ## Copyright 1996-1997 Jeffrey Hobbs, [email protected] ## ## WORK IN PROGRESS - NOT FUNCTIONAL ## package require Widget 2.0 package provide Calculator 1.0 proc Calculator args {} proc calculator args {} widget create Calculator -type frame -base frame -components { {frame menubar mbar {-relief raised -bd 1}} {listbox data data {-height 5 -bg white \ -yscrollcommand [list $data(yscrollbar) set] \ -xscrollcommand [list $data(xscrollbar) set] \ -selectbackground yellow -selectborderwidth 0 \ -selectmode single -takefocus 1}} {scrollbar yscrollbar sy {-takefocus 0 -bd 1 -orient v \ -command [list $data(data) yview]}} {scrollbar xscrollbar sx {-takefocus 0 -bd 1 -orient h \ -command [list $data(data) xview]}} {entry entry e {-bg white -takefocus 1}} {frame modef} {frame buttons} {label label lbl {-fg \#0000FF -textvariable ${w}(message)}} } -options { {-base base Base DEC} {-degree degree Degree RAD} {-menubar menuBar MenuBar 1} {-mode mode Mode Trig} {-status status Status 0} {-type type Type REG} } namespace eval ::Widget::Calculator {; variable class array set class { constants { pi 3.141592654 e 2.718281828 } } ;proc construct w { upvar \#0 [namespace current]::$w data array set data { index end modes {Scientific Logical Financial} } grid $data(menubar) - -sticky ew grid $data(data) $data(yscrollbar) -sticky news grid $data(xscrollbar) -sticky ew grid $data(entry) - -sticky ew grid $data(modef) - -sticky ew grid $data(buttons) - -sticky news grid $data(label) - -sticky ew grid columnconfig $w 0 -weight 1 grid rowconfigure $w 1 -weight 1 grid remove $data(yscrollbar) $data(xscrollbar) $data(label) initMenus $w set b $data(buttons) for {set i 0} {$i < 10} {incr i} { button $b.$i -text $i -width 3 -bg \#d9d9FF \ -command [namespace code [list _num $i]] } foreach i {A B C D E F} { button $b.[string tolower $i] -text $i -width 3 -bg \#d9d9FF \ -command [namespace code [list _num $i]] } button $b.del -text DEL -command [namespace code [list _backspace $w]] button $b.clr -text CLR -command [namespace code [list _clear $w]] button $b.drop -text Drop -command [namespace code [list _drop $w]] button $b.swap -text Swap -command [namespace code [list _swap $w]] button $b.sign -text +/- -command [namespace code [list _changesign $w]] button $b.inv -text 1/x -command [namespace code [list _invert $w]] button $b.xtoy -text x^y -command [namespace code [list _func $w pow]] button $b.sqr -text x^2 -command [namespace code [list _sqr $w]] button $b.sqrt -text Sqrt -command [namespace code [list _sqrt $w]] button $b.perc -text % -command [namespace code [list _percent $w]] button $b.dot -text . -command [namespace code [list _decimal $w]] button $b.add -text + -bg yellow \ -command [namespace code [list _binary $w +]] button $b.sub -text - -bg yellow \ -command [namespace code [list _binary $w -]] button $b.mul -text * -bg yellow \ -command [namespace code [list _binary $w *]] button $b.div -text / -bg yellow \ -command [namespace code [list _binary $w /]] grid $b.inv $b.sqr $b.sqrt $b.perc -sticky news grid $b.d $b.e $b.f $b.clr -sticky nsew grid $b.a $b.b $b.c $b.del -sticky nsew grid $b.7 $b.8 $b.9 $b.add -sticky nsew grid $b.4 $b.5 $b.6 $b.sub -sticky nsew grid $b.1 $b.2 $b.3 $b.mul -sticky nsew grid $b.sign $b.0 $b.dot $b.div -sticky nsew grid columnconfig $b 0 -weight 1 grid columnconfig $b 1 -weight 1 grid columnconfig $b 2 -weight 1 grid columnconfig $b 3 -weight 1 ## Standard bindings ## bind Calculator <<CalcNumber>> [namespace code [list _num $i]] bind Calculator <<CalcBinOp>> [namespace code [list _binary $w %K]] event add <<CalcBinOp>> <KP_Add> <KP_Subtract> <KP_Multiply> <KP_Divide> \ + - * / bind Calculator <Return> [namespace code [list _enter $w]] bind Calculator <KP_Enter> [namespace code [list _enter $w]] bind Calculator <KP_Decimal> [namespace code [list _decimal $w]] bind Calculator . [namespace code [list _decimal $w]] bind Calculator <Shift-BackSpace> [namespace code [list _drop $w]] bind Calculator <BackSpace> [namespace code [list _backspace $w]] _push $w {} recursive_bind $w } ;proc configure {w args} { upvar \#0 [namespace current]::$w data set truth {^(1|yes|true|on)$} foreach {key val} $args { switch -- $key { -base { if {![regexp -nocase {^(DEC|HEX|OCT|BIN)$} $val]} { return -code error "bad value \"$val\", must be one of:\ dec, hex, oct, bin" } set val [string toupper $val] } -degree { if {![regexp -nocase {^(RAD|GRAD|DEG)$} $val]} { return -code error "bad value \"$val\",\ must be one of: rad, grad, deg" } set val [string toupper $val] } -menubar { if {[set val [regexp -nocase $truth $val]]} { grid $data(menubar) } else { grid remove $data(menubar) } } -mode { if {![regexp -nocase ^([join $data(modes) |])\$ $val]} { return -code error "bad value \"$val\",\ must be one of: [join $data(modes) {, }]" } set val [string toupper $val] } -status { if {[set val [regexp -nocase $truth $val]]} { grid $data(label) } else { grid remove $data(label) } } -type { if {![regexp -nocase ^([join $data(types) |])\$ $val]} { return -code error "bad value \"$val\",\ must be one of: [join $data(types) {, }]" } set val [string toupper $val] } } set data($key) $val } } ;proc recursive_bind w { foreach c [winfo children $w] { if {[string compare Entry [winfo class $c]]} { bindtags $c [concat [bindtags $c] Calculator] } recursive_bind $c } } ;proc initMenus w { upvar \#0 [namespace current]::$w data ## File Menu ## set m $data(menubar).file pack [menubutton $m -text "File" -underline 0 -menu $m.m] -side left set m [menu $m.m] $m add command -label "Save" -underline 0 ## Math Menu ## set m $data(menubar).math pack [menubutton $m -text "Math" -underline 0 -menu $m.m] -side left set m [menu $m.m] $m add cascade -label "Constants" -menu $m.const ## Constants Menu ## menu $m.const -postcommand [list winConst $w $m.const] ## Help Menu ## set m $data(menubar).help pack [menubutton $m -text "Help" -underline 0 -menu $m.m] -side right set m [menu $m.m] $m add command -label "About" -command [list _about $w] } ;proc calcerror {w msg} { upvar \#0 [namespace current]::$w data if {[string compare $msg {}]} { tk_dialog $w.error "Calculator Error" $msg error 0 Oops } } ;proc _constant {w type} { upvar \#0 [namespace current]::$w data array set const $data(constants) _push $w {} } ;proc _convert {w from to args} { upvar \#0 [namespace current]::$w data foreach num $args { } } ;proc _changesign w { upvar \#0 [namespace current]::$w data set arg1 [_pop $w] if {[string match {} $arg1]} { return 0 } _push $w [expr 0 - $arg1] _push $w {} } ;proc _drop w { upvar \#0 [namespace current]::$w data _pop $w _push $w {} } ;proc _backspace w { upvar \#0 [namespace current]::$w data if {[string match {} [_peek $w]]} { _pop $w _push $w {} return } set arg1 [_pop $w] set arg2 [string trimright $arg1 .] _push $w $arg2 } ;proc _binary {w op} { upvar \#0 [namespace current]::$w data set arg1 [_pop $w] set arg2 [_pop $w] if {[string match {} $arg2]} { _push $w $arg1 if {[string compare $arg1 {}]} { _push $w {} } return } _push $w [expr double($arg2) $op $arg1] _push $w {} } ;proc commify {w ip} { upvar \#0 [namespace current]::$w data if {[string len $ip] > 3} { set fmt {([0-9])([0-9])([0-9])} switch [expr [string len $ip]%3] { 0 { regsub -all $fmt $ip {\1\2\3,} ip } 1 { regsub -all $fmt $ip {\1,\2\3} ip } 2 { regsub -all $fmt $ip {\1\2,\3} ip } } set ip [string trimright $ip ,] } return $ip } ;proc _decimal w { upvar \#0 [namespace current]::$w data if {[string match {} [$data(data) get $data(index)]]} { _push $w 0. } else { set arg1 [_pop $w] _push $w [string trimright $arg1 .]. } } ;proc _enter w { upvar \#0 [namespace current]::$w data set push 0 if {[string match {} [$data(data) get $data(index)]]} { set push 1 } set stk [_pop $w] if {[string match {} $stk]} { return 0 } _push $w $stk if $push { _push $w $stk } _push $w {} } ;proc _func {w op} { upvar \#0 [namespace current]::$w data set arg1 [_pop $w] set arg2 [_pop $w] if {[string match {} $arg2]} { _push $w $arg1 if {[string compare $arg1 {}]} { _push $w {} } return 0 } _push $w [expr $op ($arg2, $arg1)] _push $w {} } ;proc _invert w { upvar \#0 [namespace current]::$w data if {[string match {} [set arg1 [_pop $w]]} { return 0 } if {$arg1 == 0} { calcerror $w "Division by 0 error" return 0 } _push $w [expr 1.0 / $arg1] _push $w {} } ;proc _num {w val} { upvar \#0 [namespace current]::$w data set idx $data(index) if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx set stk {} } else { set stk [_pop $w $idx] } _push $w $stk$val $idx } ;proc _swap w { upvar \#0 [namespace current]::$w data set arg1 [_pop $w] set arg2 [_pop $w] if {[string compare $arg2 {}]} { _push $w $arg1 if {[string compare $arg1 {}]} { _push $w {} } return 0 } _push $w $arg1 _push $w $arg2 _push $w {} } ;proc _unary {w op} { upvar \#0 [namespace current]::$w data set arg1 [_pop $w] if {[llength $arg1]} { _push $w [expr $op ($arg1)] _push $w {} } else { return 0 } } ;proc _peek {w {idx {}}} { upvar \#0 [namespace current]::$w data if {[string match {} $idx]} { set idx [$data(data) curselection] } if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx } regsub -all {,} [$data(data) get $idx] {} val return $val } ;proc _pop {w {idx {}}} { upvar \#0 [namespace current]::$w data if {[string match {} $idx]} { set idx [$data(data) curselection] } if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx } set val [$data(data) get $idx] if {[string match {} $val]} { calcerror $w "Not enough arguments" return } $data(data) delete $idx regsub -all {,} $val {} val $data(data) selection clear 0 end $data(data) selection set $idx $idx $data(data) see $idx if {[string compare end $data(index)]} { set data(index) [expr $idx+1] } return $val } ;proc _push {w val {idx {}}} { upvar \#0 [namespace current]::$w data if {[string match {} $idx]} { set idx $data(index) } if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx } switch $data(-base) { DEC { regsub -all {^0+} $val {} val ## break into sign, integer, fractional and exponent parts if {[regexp {^([-+])?([0-9]*)(\.)?([0-9]*)?(e[-+]?[0-9]+)?$} \ $val full sign ip dec fp ee]} { if {[string match {} $ip]} { if {[string compare $full {}]} { set ip 0 } } else { set ip [commify $w $ip] } set val $sign$ip$dec$fp$ee } else { #if [scan $val %d] } } OCT { if {![regsub -all {^0+} $val {0} val]} { set val 0$val } } HEX { } BIN { } } $data(data) insert $idx $val $data(data) selection clear 0 end $data(data) selection set $idx $idx $data(data) see $idx #set data(index) $idx } }; # end namespace ::Widget::Calculator |
Added library/combobox.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 | ## ## Copyright 1996-8 Jeffrey Hobbs, [email protected] ## package require Widget 2.0 package provide Combobox 2.0 ## FIX: ## popdown listbox on Configure ##------------------------------------------------------------------------ ## PROCEDURE ## combobox ## ## DESCRIPTION ## Implements a Combobox megawidget ## ## ARGUMENTS ## combobox <window pathname> <options> ## ## OPTIONS ## (Any entry widget option may be used in addition to these) ## ## -click single|double DEFAULT: double ## Whether a single or double-click will select an item in the listbox. ## If you choose single click, then the selection will follow the ## motion of the mouse (Windows-like). ## ## -command script DEFAULT: {} ## Script to evaluate when a selection is made. ## ## -editable TCL_BOOLEAN DEFAULT: 1 ## Whether to allow the user to edit the entry widget contents ## ## -grab type DEFAULT: local ## Type of grab (local, none, global) to use when listbox appears. ## ## -labelanchor anchor DEFAULT: c ## Anchor for the label. Reasonable values are c, w and e. ## ## -labeltext string DEFAULT: {} ## Text for the label ## ## -labelwidth # DEFAULT: 0 (self-sizing) ## Width for the label ## ## -list list DEFAULT: {} ## List for the listbox ## ## -listheight # DEFAULT: 5 ## Height of the listbox. If the number of items exceeds this ## height, a scrollbar will automatically be added. 0 means auto-size ## ## -postcommand script DEFAULT: {} ## A command which is evaluated before the listbox pops up. ## ## -prunelist TCL_BOOLEAN DEFAULT: 0 ## Whether to prevent duplicate listbox items ## ## -state normal|disabled DEFAULT: normal ## Same as for entry, but also disables the button ## ## -tabexpand TCL_BOOLEAN DEFAULT: 1 ## Whether to allow tab expansion in entry widget (uses listbox items) ## ## RETURNS: the window pathname ## ## BINDINGS (in addition to default widget bindings) ## ## <Double-1> or <Escape> in the entry widget, or selecting the ## button will toggle the listbox portion. ## ## <Escape> will close the listbox without a selection. ## ## <Tab> in the entry widget searches the listbox for a unique match. ## ## <(Double-)1> in the listbox selects that item, configurable with -click. ## ## METHODS ## These are the methods that the Combobox recognizes. Aside from ## those listed here, it accepts what is valid for entry widgets. ## ## configure ?option? ?value option value ...? ## cget option ## Standard tk widget routines. ## ## add ?string? ## Adds the string to the listbox. ## If string is not specified, it uses what's in the entry widget. ## ## expand ?string? ## Expands the string based on the contents of the listbox. ## If string is not specified, it uses what's in the entry widget. ## ## popdown ## Pops the listbox down (no error when already unmapped) ## ## popup ## Pops the listbox up (no error when already mapped) ## ## toggle ## Toggles whether the listbox is mapped or not. ## ## set string ## Sets the entry widget (or its textvariable, if it exists) to ## the value of string. ## ## subwidget widget ## Returns the true widget path of the specified widget. Valid ## widgets are label, listbox, entry, toplevel, scrollbar. ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ## EXAMPLE USAGE: ## ## pack [combobox .combo -label "Hello: "] ## pack [combobox .combo -width 15 -textvariable myvar] ## ##------------------------------------------------------------------------ # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc Combobox args {} proc combobox args {} widget create Combobox -type frame -base entry -components { label {button button button {-image ::Widget::Combobox::Image \ -command [namespace code [list _toggle $w]]}} {toplevel toplevel drop {-cursor arrow}} {listbox listbox drop.lbox {-selectmode single \ -width 5 -height $data(-listheight) \ -yscrollcommand [list $data(scrollbar) set]}} {scrollbar scrollbar drop.sy {-orient vertical \ -command [list $data(listbox) yview]}} } -options { {-bd -borderwidth} {-borderwidth borderWidth BorderWidth 0} {-bg -background} {-background ALIAS entry -background} {-click click Click double} {-command command Command {}} {-editable editable Editable 1} {-grab grab Grab local} {-labeltext labelText Text {}} {-labelwidth labelWidth Width 0} {-labelanchor ALIAS label -anchor labelAnchor Anchor} {-list list List {}} {-listheight listHeight ListHeight 5} {-postcommand postCommand Command {}} {-prunelist pruneList PruneList 0} {-relief relief Relief flat} {-state ALIAS entry -state} {-tabexpand tabExpand TabExpand 1} } namespace eval ::Widget::Combobox {; namespace import -force ::Utility::best_match ;proc construct {w} { variable $w upvar 0 $w data ## Removable List Box wm overrideredirect $data(toplevel) 1 wm transient $data(toplevel) [winfo toplevel $w] wm group $data(toplevel) [winfo toplevel $w] ## this shouldn't be necessary... (bug on Windows?) wm withdraw $data(toplevel) bind $data(toplevel) <Unmap> [list catch [list grab release $w]] grid $data(label) $data(entry) $data(button) -in $w -sticky news grid configure $data(button) -sticky ns grid columnconfig $w 1 -weight 1 grid $data(listbox) $data(scrollbar) -in $data(toplevel) -sticky ns grid configure $data(listbox) -sticky news grid remove $data(scrollbar) $data(label) grid columnconfig $data(toplevel) 0 -weight 1 grid rowconfigure $data(toplevel) 0 -weight 1 ## These are not in a class (like ComboboxList) because we need to ## allow -click to work on an instance basis. For the same reason, ## we can't use any virtual events. bind $data(listbox) <Escape> [namespace code [list $w popdown]] bind $data(listbox) <Double-1> \ [namespace code "get [list $w] \[%W get \[%W nearest %y\]\]"] bind $data(listbox) <Return> \ [namespace code "get [list $w] \[%W get active\]"] } ;proc configure { w args } { variable $w upvar 0 $w data set truth {^(1|yes|true|on)$} foreach {key val} $args { switch -- $key { -borderwidth - -relief { .$w configure $key $val } -background { $data(basecmd) configure -bg $val $data(listbox) configure -bg $val } -click { switch [string tolower $val] { single { bind $data(listbox) <Double-1> {} bind $data(listbox) <1> [namespace code "get \ [list $w] \[%W get \[%W nearest %y\]\]"] bind $data(listbox) <Motion> { %W selection clear 0 end %W selection set [%W nearest %y] } } double { bind $data(listbox) <Double-1> [namespace code "get \ [list $w] \[%W get \[%W nearest %y\]\]"] bind $data(listbox) <1> {} bind $data(listbox) <Motion> {} } default { return -code error "bad $key option \"$val\": must be\ single or double" } } } -editable { if {[set val [regexp $truth $val]]} { $data(basecmd) configure -state normal } else { $data(basecmd) configure -state disabled } } -grab { if {![regexp {^(local|global|none)$} $val junk val]} { return -code error "bad $key option \"$val\": must be\ local, grab, or none" } } -list { $data(listbox) delete 0 end eval $data(listbox) insert end $val } -labelanchor { $data(label) configure -anchor $val } -labeltext { $data(label) configure -text $val if {[string compare {} $val]} { grid $data(label) } else { grid remove $data(label) } } -labelwidth { $data(label) configure -width $val } -listheight { $data(listbox) configure -height $val } -state { $data(basecmd) configure -state $val $data(button) configure -state $val if {[string match "disabled" $val] && \ [winfo ismapped $data(toplevel)]} { wm withdraw $data(toplevel) catch {grab release $w} } } -prunelist - -tabexpand { set val [regexp $truth $val] } } set data($key) $val } } bind Combobox <Double-1> { %W toggle } bind Combobox <Escape> { %W toggle } bind Combobox <Tab> { %W expand [%W get]; break } bind Combobox <Unmap> { catch {grab release %W} } bind Combobox <Destroy> { catch {grab release %W} } ;proc _toggle {w} { variable $w upvar 0 $w data if {[winfo ismapped $data(toplevel)]} { _popdown $w } else { _popup $w } } ;proc _popup {w} { variable $w upvar 0 $w data if {[winfo ismapped $data(toplevel)]} { return } global tcl_platform uplevel \#0 $data(-postcommand) focus $data(entry) set size [$data(listbox) size] ## If -listheight is 0, the listbox will auto-size if {$data(-listheight) && ($size > $data(-listheight))} { $data(listbox) configure -height $data(-listheight) grid $data(scrollbar) } else { $data(listbox) configure -height $size grid remove $data(scrollbar) } ## The update is required to get the window to properly size itself ## before it is popped up the first time. update idletasks set W [expr {[winfo width $data(entry)]+[winfo width $data(button)]}] set H [winfo reqheight $data(toplevel)] set y [expr {[winfo rooty $data(entry)]+[winfo height $data(entry)]}] ## Make it pop up upwards if there is not enough screen downwards if {($y+$H)>[winfo screenheight $w]} { set y [expr {[winfo rooty $data(entry)]-$H}] } set x [winfo rootx $data(entry)] wm geometry $data(toplevel) ${W}x${H}+${x}+${y} ## This is required to get the window to pop up in the right place ## on Windows, doesn't affect Unix update idletasks wm deiconify $data(toplevel) if {[string match local $data(-grab)]} { grab $w } elseif {[string match global $data(-grab)]} { grab -global $w } raise $data(toplevel) focus $data(listbox) } ;proc _popdown {w} { variable $w upvar 0 $w data if {![winfo ismapped $data(toplevel)]} { return } wm withdraw $data(toplevel) catch {grab release $w} focus $data(entry) } ;proc _expand {w {str {}}} { variable $w upvar 0 $w data if {!$data(-tabexpand)} return if {[string match {} $str]} { set str [$data(basecmd) get] } set found 0 foreach item [$data(listbox) get 0 end] { if {[string match ${str}* $item]} { incr found lappend match $item } } if {$found} { set state [$data(basecmd) cget -state] $data(basecmd) config -state normal $data(basecmd) delete 0 end if {$found>1} { set match [best_match $match $str] } else { set match [lindex $match 0] } $data(basecmd) insert end $match $data(basecmd) config -state $state } else { bell } } ;proc _add {w {str {}}} { variable $w upvar 0 $w data if {[string match {} $str]} { set str [$data(basecmd) get] } set i 1 if {!$data(-prunelist)} { foreach l [$data(listbox) get 0 end] { if {![string compare $l $str]} { set i 0 ; break } } } if {$i} { $data(listbox) insert end $str } } ;proc _set {w str} { variable $w upvar 0 $w data set var [$data(basecmd) cget -textvar] if {[string compare {} $var] && [uplevel \#0 info exists [list $var]]} { global $var set $var $str } else { set state [$data(basecmd) cget -state] $data(basecmd) config -state normal $data(basecmd) delete 0 end $data(basecmd) insert 0 $str $data(basecmd) config -state $state } } ;proc get {w i} { variable $w upvar 0 $w data set e $data(basecmd) if {[$data(listbox) size]} { set state [$e cget -state] $e config -state normal $e delete 0 end $e insert end $i $e config -state $state if {[string compare $data(-command) {}]} { uplevel \#0 $data(-command) $i } } wm withdraw $data(toplevel) focus $data(base) } }; # end namespace ::Widget::Combobox ## Button Bitmap ## image create bitmap ::Widget::Combobox::Image -data {#define downbut_width 14 #define downbut_height 14 static char downbut_bits[] = { 0x00, 0x00, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xfc, 0x0f, 0xf8, 0x07, 0xf0, 0x03, 0xe0, 0x01, 0xc0, 0x00, 0x00, 0x00, 0xfe, 0x1f, 0xfe, 0x1f, 0x00, 0x00}; } return |
Added library/console.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 | ## ## Copyright 1996-8 Jeffrey Hobbs, [email protected] ## ## Based off previous work for TkCon ## package require Widget 2.0 ## From ::Utility, we need: ## lremove ## and we get for slaves (not necessary): ## alias, echo, dir/ls, dump #package require ::Utility 1.0 ;proc lremove {args} { set all 0 if {[string match \-a* [lindex $args 0]]} { set all 1 set args [lreplace $args 0 0] } set l [lindex $args 0] foreach i [join [lreplace $args 0 0]] { if {[set ix [lsearch -exact $l $i]] == -1} continue set l [lreplace $l $ix $ix] if {$all} { while {[set ix [lsearch -exact $l $i]] != -1} { set l [lreplace $l $ix $ix] } } } return $l } # highlight -- # searches in text widget for $str and highlights it # If $str is empty, it just deletes any highlighting # This really belongs in ::Utility::tk # Arguments: # w text widget # str string to search for # -nocase specifies to be case insensitive # -regexp specifies that $str is a pattern # -tag tagId name of tag in text widget # -color color color of tag in text widget # Results: # Returns ... # ;proc highlight {w str args} { $w tag remove __highlight 1.0 end array set opts { -nocase 0 -regexp 0 -tag __highlight -color yellow } set args [get_opts opts $args {-nocase 0 -regexp 0 -tag 1 -color 1}] if {[string match {} $str]} return set pass {} if {$opts(-nocase)} { append pass "-nocase " } if {$opts(-regexp)} { append pass "-regexp " } $w tag configure $opts(-tag) -background $opts(-color) $w mark set $opts(-tag) 1.0 while {[string compare {} [set ix [eval $w search $pass -count numc -- \ [list $str] $opts(-tag) end]]]} { $w tag add $opts(-tag) $ix ${ix}+${numc}c $w mark set $opts(-tag) ${ix}+1c } catch {$w see $opts(-tag).first} return [expr {[llength [$w tag ranges $opts(-tag)]]/2}] } # highlight_dialog -- # # creates minimal dialog interface to highlight # # Arguments: # w text widget # str optional seed string for HIGHLIGHT(string) # Results: # Returns null. # proc highlight_dialog {w {str {}}} { variable HIGHLIGHT set namesp [namespace current] set var ${namesp}::HIGHLIGHT set base $w.__highlight if {![winfo exists $base]} { toplevel $base wm withdraw $base wm title $base "Find String" pack [frame $base.f] -fill x -expand 1 label $base.f.l -text "Find:" entry $base.f.e -textvariable ${var}($w,string) pack [frame $base.opt] -fill x checkbutton $base.opt.c -text "Case Sensitive" \ -variable ${var}($w,nocase) checkbutton $base.opt.r -text "Use Regexp" -variable ${var}($w,regexp) pack $base.f.l -side left pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1 pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x pack [frame $base.btn] -fill both button $base.btn.fnd -text "Find" -width 6 button $base.btn.clr -text "Clear" -width 6 button $base.btn.dis -text "Dismiss" -width 6 eval pack [winfo children $base.btn] -padx 4 -pady 2 \ -side left -fill both focus $base.f.e bind $base.f.e <Return> [list $base.btn.fnd invoke] bind $base.f.e <Escape> [list $base.btn.dis invoke] } ## FIX namespace $base.btn.fnd config -command [namespace code \ "highlight [list $w] \[set ${var}($w,string)\] \ \[expr {\[set ${var}($w,nocase)\]?{}:{-nocase}}] \ \[expr {\[set ${var}($w,regexp)\]?{-regexp}:{}}] \ -tag __highlight -color [list yellow]"] $base.btn.clr config -command \ "[list $w] tag remove __highlight 1.0 end;\ set [list ${var}($w,string)] {}" $base.btn.dis config -command \ "[list $w] tag remove __highlight 1.0 end;\ wm withdraw [list $base]" if {[string compare {} $str]} { set ${var}($w,string) $str $base.btn.fnd invoke } if {[string compare normal [wm state $base]]} { wm deiconify $base } else { raise $base } $base.f.e select range 0 end } package provide Console 2.0 ##------------------------------------------------------------------------ ## PROCEDURE ## console ## ## DESCRIPTION ## Implements a console mega-widget ## ## ARGUMENTS ## console <window pathname> <options> ## ## OPTIONS ## (Any frame widget option may be used in addition to these) ## ## -blinkcolor color DEFAULT: #FFFF00 (yellow) ## Specifies the background blink color for brace highlighting. ## This doubles as the highlight color for the find box. ## ## -blinkrange TCL_BOOLEAN DEFAULT: 1 ## When doing electric brace matching, specifies whether to blink ## the entire range or just the matching braces. ## ## -blinktime delay DEFAULT: 500 ## For electric brace matching, specifies the amount of time to ## blink the background for. ## ## -grabputs TCL_BOOLEAN DEFAULT: 1 ## Whether this console should grab the "puts" default output ## ## -lightbrace TCL_BOOLEAN DEFAULT: 1 ## Specifies whether to activate electric brace matching. ## ## -lightcmd TCL_BOOLEAN DEFAULT: 1 ## Specifies whether to highlight recognized commands. ## ## -proccolor color DEFAULT: #008800 (darkgreen) ## Specifies the color to highlight recognized procs. ## ## -prompt string DEFAULT: {([file tail [pwd]]) [history nextid] % } ## The equivalent of the tcl_prompt1 variable. ## ## -promptcolor color DEFAULT: #8F4433 (brown) ## Specifies the prompt color. ## ## -stdincolor color DEFAULT: #000000 (black) ## Specifies the color for "stdin". ## This doubles as the console foreground color. ## ## -stdoutcolor color DEFAULT: #0000FF (blue) ## Specifies the color for "stdout". ## ## -stderrcolor color DEFAULT: #FF0000 (red) ## Specifies the color for "stderr". ## ## -showmultiple TCL_BOOLEAN DEFAULT: 1 ## For file/proc/var completion, specifies whether to display ## completions when multiple choices are possible. ## ## -showmenu TCL_BOOLEAN DEFAULT: 1 ## Specifies whether to show the menubar. ## ## -subhistory TCL_BOOLEAN DEFAULT: 1 ## Specifies whether to allow substitution in the history. ## ## -varcolor color DEFAULT: #FFC0D0 (pink) ## Specifies the color for "stderr". ## ## RETURNS: the window pathname ## ## BINDINGS (these are the bindings for Console, used in the text widget) ## ## <<Console_ExpandFile>> <Key-Tab> ## <<Console_ExpandProc>> <Control-Shift-Key-P> ## <<Console_ExpandVar>> <Control-Shift-Key-V> ## <<Console_Tab>> <Control-Key-i> ## <<Console_Eval>> <Key-Return> <Key-KP_Enter> ## ## <<Console_Clear>> <Control-Key-l> ## <<Console_KillLine>> <Control-Key-k> ## <<Console_Transpose>> <Control-Key-t> ## <<Console_ClearLine>> <Control-Key-u> ## <<Console_SaveCommand>> <Control-Key-z> ## ## <<Console_Prev>> <Key-Up> ## <<Console_Next>> <Key-Down> ## <<Console_NextImmediate>> <Control-Key-n> ## <<Console_PrevImmediate>> <Control-Key-p> ## <<Console_PrevSearch>> <Control-Key-r> ## <<Console_NextSearch>> <Control-Key-s> ## ## <<Console_Exit>> <Control-Key-q> ## <<Console_New>> <Control-Key-N> ## <<Console_Close>> <Control-Key-w> ## <<Console_About>> <Control-Key-A> ## <<Console_Help>> <Control-Key-H> ## <<Console_Find>> <Control-Key-F> ## ## METHODS ## These are the methods that the console megawidget recognizes. ## ## configure ?option? ?value option value ...? ## cget option ## Standard tk widget routines. ## ## load ?filename? ## Loads the named file into the current interpreter. ## If no file is specified, it pops up the file requester. ## ## save ?filename? ## Saves the console buffer to the named file. ## If no file is specified, it pops up the file requester. ## ## clear ?percentage? ## Clears a percentage of the console buffer (1-100). If no ## percentage is specified, the entire buffer is cleared. ## ## error ## Displays the last error in the interpreter in a dialog box. ## ## hide ## Withdraws the console from the screen ## ## history ?-newline? ## Prints out the history without numbers (basically providing a ## list of the commands you've used). ## ## show ## Deiconifies and raises the console ## ## subwidget widget ## Returns the true widget path of the specified widget. Valid ## widgets are console, yscrollbar, menubar. ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ## EXAMPLE USAGE: ## ## console .con -height 20 -showmenu false ## pack .con -fill both -expand 1 ##------------------------------------------------------------------------ foreach pkg [info loaded {}] { set file [lindex $pkg 0] set name [lindex $pkg 1] if {![catch {set version [package require $name]}]} { if {[string match {} [package ifneeded $name $version]]} { package ifneeded $name $version "load [list $file $name]" } } } catch {unset file name version} # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc Console args {} proc console args {} widget create Console -type frame -base text -components { {base console console {-wrap char -setgrid 1 \ -yscrollcommand [list $data(yscrollbar) set] \ -foreground $data(-stdincolor)}} {frame menubar menubar {-relief raised -bd 1}} {scrollbar yscrollbar sy {-takefocus 0 -bd 1 \ -command [list $data(console) yview]}} } -options { {-blinkcolor blinkColor BlinkColor \#FFFF00} {-proccolor procColor ProcColor \#008800} {-promptcolor promptColor PromptColor \#8F4433} {-stdincolor stdinColor StdinColor \#000000} {-stdoutcolor stdoutColor StdoutColor \#0000FF} {-stderrcolor stderrColor StderrColor \#FF0000} {-varcolor varColor VarColor \#FFC0D0} {-blinkrange blinkRange BlinkRange 1} {-blinktime blinkTime BlinkTime 500} {-grabputs grabPuts GrabPuts 1} {-lightbrace lightBrace LightBrace 1} {-lightcmd lightCmd LightCmd 1} {-showmultiple showMultiple ShowMultiple 1} {-showmenu showMenu ShowMenu 1} {-subhistory subhistory SubHistory 1} {-abouttext aboutText AboutText {}} } if {[info exists ::embed_args] || [info exists ::browser_args]} { widget add Console option {-prompt prompt Prompt {[history nextid] % }} } else { widget add Console option {-prompt prompt Prompt \ {([file tail [pwd]]) [history nextid] % }} } widget add Console option [list -abouttitle aboutTitle AboutTitle \ "About Console v[package provide Console]"] ## ## BEGIN CONSOLE DIALOG ## # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc ConsoleDialog args {} proc consoledialog args {} widget create ConsoleDialog -type toplevel -base console -options { {-title title Title "Console Dialog"} } namespace eval ::Widget::ConsoleDialog {; variable class array set class [list version [package provide Console]] ;proc construct {w} { set namesp [namespace current] upvar \#0 ${namesp}::$w data variable class wm title $w $data(-title) grid $data(console) -in $w -sticky news grid columnconfig $w 0 -weight 1 grid rowconfig $w 0 -weight 1 } ;proc configure {w args} { upvar \#0 [namespace current]::$w data #variable class #set truth {^(1|yes|true|on)$} foreach {key val} $args { switch -- $key { -title { wm title $w $val } } set data($key) $val } } ;proc _hide w { if {[winfo exists $w]} { wm withdraw $w } } ;proc _show w { if {[winfo exists $w]} { wm deiconify $w; raise $w } } }; # end namespace ::Widget::ConsoleDialog ## ## END CONSOLE DIALOG ## ## ## CONSOLE MEGAWIDGET ## namespace eval ::Widget::Console {; variable class array set class { release {December 1998} contact "[email protected]" docs "http://www.purl.org/net/hobbs/tcl/script/tkcon/" slavealias { console } slaveprocs { alias dir dump lremove puts echo unknown tcl_unknown which } } if {![info exists class(active)]} { set class(active) {} } set class(version) [package provide Console] set class(WWW) [expr [info exists ::embed_args]||[info exists ::browser_args]] catch {highlight} if {[string compare {} [info commands ::Utility::lremove]]} { namespace import -force ::Utility::* } ## console - # ARGS: w - widget pathname of the Console console # Calls: InitUI # Outputs: errors found in Console resource file ## ;proc construct {w} { upvar \#0 [namespace current]::$w data global auto_path tcl_pkgPath tcl_interactive set tcl_interactive 0 ## Private variables array set data { app {} appname {} apptype {} namesp {} deadapp 0 cmdbuf {} cmdsave {} errorInfo {} event 1 histid 0 find {} find,case 0 find,reg 0 } if {![info exists tcl_pkgPath]} { set dir [file join [file dirname [info nameofexec]] lib] if {[string compare {} [info commands @scope]]} { set dir [file join $dir itcl] } catch {namespace eval :: [list source [file join $dir pkgIndex.tcl]]} } catch {tclPkgUnknown dummy-name dummy-version} InitMenus $w grid $data(menubar) - -sticky ew grid $data(console) $data(yscrollbar) -sticky news grid columnconfig $w 0 -weight 1 grid rowconfig $w 1 -weight 1 prompt $w "console display active\n" set c $data(console) foreach col {prompt stdout stderr stdin proc} { $c tag configure $col -foreground $data(-${col}color) } $c tag configure var -background $data(-varcolor) $c tag configure blink -background $data(-blinkcolor) } ;proc init {w} { upvar \#0 [namespace current]::$w data variable class bind $w <Destroy> [bind $class(class) <Destroy>] bindtags $w [list $w [winfo toplevel $w] all] set c $data(console) bindtags $c [list $c Console PostConsole $w all] if {$data(-grabputs) && [lsearch $class(active) $c] == -1} { set class(active) [linsert $class(active) 0 $c] } } ;proc destruct w { variable class upvar \#0 [namespace current]::$w data set class(active) [lremove $class(active) $data(console)] } ;proc configure { w args } { set namesp [namespace current] upvar \#0 ${namesp}::$w data variable class set truth {^(1|yes|true|on)$} set c $data(console) foreach {key val} $args { switch -- $key { -blinkcolor { $c tag config blink -background $val $c tag config __highlight -background $val } -proccolor { $c tag config proc -foreground $val } -promptcolor { $c tag config prompt -foreground $val } -stdincolor { $c tag config stdin -foreground $val $c config -foreground $val } -stdoutcolor { $c tag config stdout -foreground $val } -stderrcolor { $c tag config stderr -foreground $val } -blinktime { if {![regexp {[0-9]+} $val]} { return -code error "$key option requires an integer value" } elseif {$val < 100} { return -code error "$key option must be greater than 100" } } -grabputs { if {[set val [regexp -nocase $truth $val]]} { set class(active) [linsert $class(active) 0 $c] } else { set class(active) [lremove -all $class(active) $c] } } -prompt { if {[catch {namespace eval :: [list subst $val]} err]} { return -code error "\"$val\" threw an error:\n$err" } } -showmenu { if {[set val [regexp -nocase $truth $val]]} { grid $data(menubar) } else { grid remove $data(menubar) } } -lightbrace - -lightcmd - -showmultiple - -subhistory { set val [regexp -nocase $truth $val] } } set data($key) $val } } ;proc Exit {w args} { exit } ## Eval - evaluates commands input into console window ## This is the first stage of the evaluating commands in the console. ## They need to be broken up into consituent commands (by CmdSep) in ## case a multiple commands were pasted in, then each is eval'ed (by ## EvalCmd) in turn. Any uncompleted command will not be eval'ed. # ARGS: w - console text widget # Calls: CmdGet, CmdSep, EvalCmd ## ;proc Eval {w} { set incomplete [CmdSep [CmdGet $w] cmds last] $w mark set insert end-1c $w insert end \n if {[llength $cmds]} { foreach c $cmds {EvalCmd $w $c} $w insert insert $last {} } elseif {!$incomplete} { EvalCmd $w $last } $w see insert } ## EvalCmd - evaluates a single command, adding it to history # ARGS: w - console text widget # cmd - the command to evaluate # Calls: prompt # Outputs: result of command to stdout (or stderr if error occured) # Returns: next event number ## ;proc EvalCmd {w cmd} { ## HACK to get $W as we need it set W [winfo parent $w] upvar \#0 [namespace current]::$W data $w mark set output end if {[string compare {} $cmd]} { set code 0 if {$data(-subhistory)} { set ev [EvalSlave history nextid] incr ev -1 if {[string match !! $cmd]} { set code [catch {EvalSlave history event $ev} cmd] if {!$code} {$w insert output $cmd\n stdin} } elseif {[regexp {^!(.+)$} $cmd dummy evnt]} { ## Check last event because history event is broken set code [catch {EvalSlave history event $ev} cmd] if {!$code && ![string match ${evnt}* $cmd]} { set code [catch {EvalSlave history event $evnt} cmd] } if {!$code} {$w insert output $cmd\n stdin} } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { set code [catch {EvalSlave history event $ev} cmd] if {!$code} { regsub -all -- $old $cmd $new cmd $w insert output $cmd\n stdin } } } if {$code} { $w insert output $cmd\n stderr } else { ## We are about to evaluate the command, so move the limit ## mark to ensure that further <Return>s don't cause double ## evaluation of this command - for cases like the command ## has a vwait or something in it $w mark set limit end EvalSlave history add $cmd if {[catch {EvalAttached $cmd} res]} { if {[catch {EvalAttached {set errorInfo}} err]} { set data(errorInfo) "Error getting errorInfo:\n$err" } else { set data(errorInfo) $err } $w insert output $res\n stderr } elseif {[string compare {} $res]} { $w insert output $res\n stdout } } } prompt $W set data(event) [EvalSlave history nextid] } ## EvalSlave - evaluates the args in the associated slave ## args should be passed to this procedure like they would be at ## the command line (not like to 'eval'). # ARGS: args - the command and args to evaluate ## ;proc EvalSlave {args} { uplevel \#0 $args } ## EvalAttached ## ;proc EvalAttached {args} { uplevel \#0 eval $args } ## CmdGet - gets the current command from the console widget # ARGS: w - console text widget # Returns: text which compromises current command line ## ;proc CmdGet w { if {[string match {} [$w tag nextrange prompt limit end]]} { $w tag add stdin limit end-1c return [$w get limit end-1c] } } ## CmdSep - separates multiple commands into a list and remainder # ARGS: cmd - (possible) multiple command to separate # list - varname for the list of commands that were separated. # rmd - varname of any remainder (like an incomplete final command). # If there is only one command, it's placed in this var. # Returns: constituent command info in varnames specified by list & rmd. ## ;proc CmdSep {cmd list last} { upvar 1 $list cmds $last inc set inc {} set cmds {} foreach c [split [string trimleft $cmd] \n] { if {[string compare $inc {}]} { append inc \n$c } else { append inc [string trimleft $c] } if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} { ## FIX: is this necessary? if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} set inc {} } } set i [string compare $inc {}] if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} { set inc [lindex $cmds end] set cmds [lreplace $cmds end end] } return $i } ## prompt - displays the prompt in the console widget # ARGS: w - console text widget # Outputs: prompt (specified in data(-prompt)) to console ## ;proc prompt {W {pre {}} {post {}} {prompt {}}} { upvar \#0 [namespace current]::$W data set w $data(console) if {[string compare {} $pre]} { $w insert end $pre stdout } set i [$w index end-1c] if {[string compare {} $data(appname)]} { $w insert end ">$data(appname)< " prompt } if {[string compare {} $prompt]} { $w insert end $prompt prompt } else { $w insert end [EvalSlave subst $data(-prompt)] prompt } $w mark set output $i $w mark set insert end $w mark set limit insert $w mark gravity limit left if {[string compare {} $post]} { $w insert end $post stdin } $w see end } ## About - gives about info for Console ## ;proc About W { variable class upvar \#0 [namespace current]::$W data set w $W.about if {[winfo exists $w]} { wm deiconify $w } else { global tk_patchLevel tcl_patchLevel tcl_platform toplevel $w wm title $w $data(-abouttitle) button $w.b -text Dismiss -command [list wm withdraw $w] text $w.text -height 9 -bd 1 -width 62 pack $w.b -fill x -side bottom pack $w.text -fill both -side left -expand 1 $w.text tag config center -justify center $w.text tag config title -justify center -font {Courier 18 bold} $w.text insert 1.0 $data(-abouttitle) title \ "$data(-abouttext)\n\nConsole Copyright 1995-1998\ Jeffrey Hobbs, $class(contact)\ \nRelease Date: v$class(version), $class(release)\ \nDocumentation available at:\n$class(docs)\ \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center } } ## InitMenus - inits the menubar and popup for the console # ARGS: W - console megawidget ## ;proc InitMenus W { set V [namespace current]::$W upvar \#0 $V data set w $data(menubar) set text $data(console) if {[catch {menu $w.pop -tearoff 0}]} { label $w.label -text "Menus not available in plugin mode" pack $w.label return } #bind [winfo toplevel $w] <Button-3> "tk_popup $w.pop %X %Y" bind $text <Button-3> "tk_popup $w.pop %X %Y" ## Console Menu ## FIX - get the attachment stuff working set n cons set l "Console" pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side left $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n foreach m [list [menu $w.$n.m -disabledforeground $data(-promptcolor)] \ [menu $w.pop.$n -disabledforeground $data(-promptcolor)]] { $m add command -label "Console $W" -state disabled $m add command -label "Clear Console " -underline 1 \ -accelerator [event info <<Console_Clear>>] \ -command [namespace code [list _clear $W]] $m add command -label "Load File" -underline 0 \ -command [namespace code [list _load $W]] $m add cascade -label "Save ..." -underline 0 -menu $m.save $m add separator $m add cascade -label "Attach Console" -underline 7 -menu $m.apps \ -state disabled $m add cascade -label "Attach Namespace" -underline 7 -menu $m.name \ -state disabled $m add separator $m add command -label "Exit" -underline 1 \ -accelerator [event info <<Console_Exit>>] \ -command [namespace code [list Exit $W]] ## Save Menu ## set s $m.save menu $s -disabledforeground $data(-promptcolor) -tearoff 0 $s add command -label "All" -underline 0 \ -command [namespace code [list _save $W all]] $s add command -label "History" -underline 0 \ -command [namespace code [list _save $W history]] $s add command -label "Stdin" -underline 3 \ -command [namespace code [list _save $W stdin]] $s add command -label "Stdout" -underline 3 \ -command [namespace code [list _save $W stdout]] $s add command -label "Stderr" -underline 3 \ -command [namespace code [list _save $W stderr]] ## Attach Console Menu ## menu $m.apps -disabledforeground $data(-promptcolor) \ -postcommand [namespace code [list AttachMenu $W $m.apps]] ## Attach Interpreter Menu ## menu $m.int -disabledforeground $data(-promptcolor) -tearoff 0 \ -postcommand [namespace code [list AttachMenu $W $m.int interp]] ## Attach Namespace Menu ## menu $m.name -disabledforeground $data(-promptcolor) -tearoff 0 \ -postcommand [namespace code [list AttachMenu $W $m.name namespace]] } ## Edit Menu ## set n edit set l "Edit" pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side left $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] { $m add command -label "Cut" -underline 1 \ -accelerator [lindex [event info <<Cut>>] 0] \ -command [namespace code [list Cut $text]] $m add command -label "Copy" -underline 1 \ -accelerator [lindex [event info <<Copy>>] 0] \ -command [namespace code [list Copy $text]] $m add command -label "Paste" -underline 0 \ -accelerator [lindex [event info <<Paste>>] 0] \ -command [namespace code [list Paste $text]] $m add separator $m add command -label "Find" -underline 0 \ -accelerator [lindex [event info <<Console_Find>>] 0] \ -command [namespace code [list FindBox $W]] $m add separator $m add command -label "Last Error" -underline 0 \ -command [list $W error] } ## Prefs Menu ## set n pref set l "Prefs" pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side left $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] { $m add checkbutton -label "Brace Highlighting" \ -variable $V\(-lightbrace\) $m add checkbutton -label "Command Highlighting" \ -variable $V\(-lightcmd\) $m add checkbutton -label "Grab Puts Output" \ -variable $V\(-grabputs\) \ -command [namespace code "configure [list $W] \ -grabputs \[set ${V}(-grabputs)\]"] $m add checkbutton -label "History Substitution" \ -variable $V\(-subhistory\) $m add checkbutton -label "Show Multiple Matches" \ -variable $V\(-showmultiple\) $m add checkbutton -label "Show Menubar" \ -variable $V\(-showmenu\) \ -command [namespace code "configure [list $W] \ -showmenu \[set ${V}(-showmenu)\]"] } ## History Menu ## set n hist set l "History" pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side left $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n foreach m [list $w.$n.m $w.pop.$n] { menu $m -disabledforeground $data(-promptcolor) \ -postcommand [namespace code [list HistoryMenu $W $m]] } ## Help Menu ## set n help set l "Help" pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side right $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] { $m config -disabledfore $data(-promptcolor) $m add command -label "About " -underline 0 \ -accelerator [event info <<Console_About>>] \ -command [namespace code [list About $W]] } bind $W <<Console_Exit>> [namespace code [list Exit $W]] bind $W <<Console_About>> [namespace code [list About $W]] bind $W <<Console_Help>> [namespace code [list Help $W]] bind $W <<Console_Find>> [namespace code [list FindBox $W]] ## Menu items need null PostConsole bindings to avoid the TagProc ## foreach ev [bind $W] { bind PostConsole $ev { # empty } } } # AttachMenu -- # # ADD COMMENTS HERE # # Arguments: # args comments # Results: # Returns ... # ;proc AttachMenu {W m {type default}} { upvar \#0 [namespace current]::$W data } ## HistoryMenu - dynamically build the menu for attached interpreters ## # ARGS: w - menu widget ## ;proc HistoryMenu {W w} { upvar \#0 [namespace current]::$W data if {![winfo exists $w]} return set id [EvalSlave history nextid] if {$data(histid)==$id} return set data(histid) $id $w delete 0 end set con $data(console) while {$id>0 && ($id>$data(histid)-10) && \ ![catch {EvalSlave history event [incr id -1]} tmp]} { set lbl [lindex [split $tmp "\n"] 0] if {[string len $lbl]>32} { set lbl [string range $tmp 0 29]... } $w add command -label "$id: $lbl" -command [namespace code " $con delete limit end $con insert limit [list $tmp] $con see end Eval $con\n"] } } ## FindBox - creates minimal dialog interface to Find # ARGS: w - text widget # str - optional seed string for data(find) ## ;proc FindBox {W {str {}}} { set V [namespace current]::$W upvar \#0 $V data highlight_dialog $data(console) return set t $data(console) set base $W.find if {![winfo exists $base]} { toplevel $base wm withdraw $base wm title $base "Console Find" pack [frame $base.f] -fill x -expand 1 label $base.f.l -text "Find:" entry $base.f.e -textvar $V\(find\) pack [frame $base.opt] -fill x checkbutton $base.opt.c -text "Case Sensitive" -var ${V}(find,case) checkbutton $base.opt.r -text "Use Regexp" -var ${V}(find,reg) pack $base.f.l -side left pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1 pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x pack [frame $base.btn] -fill both button $base.btn.fnd -text "Find" -width 6 button $base.btn.clr -text "Clear" -width 6 button $base.btn.dis -text "Dismiss" -width 6 eval pack [winfo children $base.btn] -padx 4 -pady 2 \ -side left -fill both focus $base.f.e bind $base.f.e <Return> [list $base.btn.fnd invoke] bind $base.f.e <Escape> [list $base.btn.dis invoke] } $base.btn.fnd config -command [namespace code \ "highlight [list $data(console)] \[set ${V}(find)\] \ \[expr {\[set ${V}(find,case)\]?{}:{-nocase}}] \ \[expr {\[set ${V}(find,reg)\]?{-regexp}:{}}] \ -tag __highlight -color [list $data(-blinkcolor)]"] $base.btn.clr config -command " $t tag remove __highlight 1.0 end set ${V}(find) {} " $base.btn.dis config -command " $t tag remove __highlight 1.0 end wm withdraw $base " if {[string compare {} $str]} { set data(find) $str $base.btn.fnd invoke } if {[string compare normal [wm state $base]]} { wm deiconify $base } else { raise $base } $base.f.e select range 0 end } ## savecommand - saves a command in a buffer for later retrieval # ## ;proc savecommand {w} { upvar \#0 [namespace current]::[winfo parent $w] data set tmp $data(cmdsave) set data(cmdsave) [CmdGet $w] if {[string match {} $data(cmdsave)]} { set data(cmdsave) $tmp } else { $w delete limit end-1c } $w insert limit $tmp $w see end } ## _load - sources a file into the console # ARGS: fn - (optional) filename to source in # Returns: selected filename ({} if nothing was selected) ## ;proc _load {W {fn ""}} { set types { {{Tcl Files} {.tcl .tk}} {{Text Files} {.txt}} {{All Files} *} } if { [string match {} $fn] && ([catch {tk_getOpenFile -filetypes $types \ -title "Source File into Attached Interpreter"} fn] || [string match {} $fn]) } { return } EvalAttached [list source $fn] } ## _save - saves the console buffer to a file ## This does not eval in a slave because it's not necessary # ARGS: w - console text widget # fn - (optional) filename to save to ## ;proc _save {W {type ""} {fn ""}} { upvar \#0 [namespace current]::$W data set c $data(console) if {![regexp -nocase {^(all|history|stdin|stdout|stderr)$} $type]} { array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel } ## Allow user to specify what kind of stuff to save set type [tk_dialog $W.savetype "Save Type" \ "What part of the console text do you want to save?" \ questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)] if {$type == 5 || $type == -1} return set type $s($type) } if {[string match {} $fn]} { set types { {{Text Files} {.txt}} {{Tcl Files} {.tcl .tk}} {{All Files} *} } if {[catch {tk_getSaveFile -filetypes $types -title "Save $type"} fn] \ || [string match {} $fn]} return } set type [string tolower $type] set output {} switch $type { stdin - stdout - stderr { foreach {first last} [$c tag ranges $type] { lappend output [$c get $first $last] } set output [join $data \n] } history { set output [_history $W] } all - default { set output [$c get 1.0 end-1c] } } if {[catch {open $fn w} fid]} { return -code error "Save Error: Unable to open '$fn' for writing\n$fid" } puts $fid $output close $fid } ## clear - clears the buffer of the console (not the history though) ## ;proc _clear {W {pcnt 100}} { upvar \#0 [namespace current]::$W data set data(tmp) [CmdGet $data(console)] if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { return -code error \ "invalid percentage to clear: must be 1-100 (100 default)" } elseif {$pcnt == 100} { $data(console) delete 1.0 end } else { set tmp [expr $pcnt/100.0*[$data(console) index end]] $data(console) delete 1.0 "$tmp linestart" } prompt $W {} $data(tmp) } ;proc _error {W} { ## Outputs stack caused by last error. upvar \#0 [namespace current]::$W data set info $data(errorInfo) if {[string match {} $info]} { set info {errorInfo empty} } catch {destroy $W.error} set w [toplevel $W.error] wm title $w "Console Last Error" button $w.close -text Dismiss -command [list destroy $w] scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview] text $w.text -yscrollcommand [list $w.sy set] pack $w.close -side bottom -fill x pack $w.sy -side right -fill y pack $w.text -fill both -expand 1 $w.text insert 1.0 $info $w.text config -state disabled } ## _event - searches for history based on a string ## Search forward (next) if $int>0, otherwise search back (prev) # ARGS: W - console widget ## ;proc _event {W int {str {}}} { upvar \#0 [namespace current]::$W data if {!$int} return set w $data(console) set nextid [EvalSlave history nextid] if {[string compare {} $str]} { ## String is not empty, do an event search set event $data(event) if {$int < 0 && $event == $nextid} { set data(cmdbuf) $str } set len [string len $data(cmdbuf)] incr len -1 if {$int > 0} { ## Search history forward while {$event < $nextid} { if {[incr event] == $nextid} { $w delete limit end $w insert limit $data(cmdbuf) break } elseif {![catch {EvalSlave history event $event} res] \ && ![string compare $data(cmdbuf) \ [string range $res 0 $len]]} { $w delete limit end $w insert limit $res break } } set data(event) $event } else { ## Search history reverse while {![catch {EvalSlave history event [incr event -1]} res]} { if {![string compare $data(cmdbuf) \ [string range $res 0 $len]]} { $w delete limit end $w insert limit $res set data(event) $event break } } } } else { ## String is empty, just get next/prev event if {$int > 0} { ## Goto next command in history if {$data(event) < $nextid} { $w delete limit end if {[incr data(event)] == $nextid} { $w insert limit $data(cmdbuf) } else { $w insert limit [EvalSlave history event $data(event)] } } } else { ## Goto previous command in history if {$data(event) == $nextid} {set data(cmdbuf) [CmdGet $w]} if {[catch {EvalSlave history event [incr data(event) -1]} res]} { incr data(event) } else { $w delete limit end $w insert limit $res } } } $w mark set insert end $w see end } ;proc _history {W args} { set sub {\2} if {[string match -n* $args]} { append sub "\n" } set h [EvalSlave history] regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h return $h } ## ## Some procedures to make up for lack of built-in shell commands ## ## puts ## This allows me to capture all stdout/stderr to the console window # ARGS: same as usual # Outputs: the string with a color-coded text tag ## if {![catch {rename ::puts ::console_tcl_puts}]} { ;proc ::puts args { if {![catch {widget value Console active} active] && \ [winfo exists [lindex $active 0]]} { set w [lindex $active 0] set len [llength $args] if {$len==1} { eval $w insert output $args stdout {\n} stdout $w see output } elseif {$len==2 && [regexp {(stdout|stderr|-nonewline)} \ [lindex $args 0] junk tmp]} { if {[string compare $tmp -nonewline]} { eval $w insert output [lreplace $args 0 0] $tmp {\n} $tmp } else { eval $w insert output [lreplace $args 0 0] stdout } $w see output } elseif {$len==3 && \ [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { if {[string compare [lreplace $args 1 2] -nonewline]} { eval $w insert output [lrange $args 1 1] $tmp } else { eval $w insert output [lreplace $args 0 1] $tmp } $w see output } else { global errorCode errorInfo if {[catch "::console_tcl_puts $args" msg]} { regsub console_tcl_puts $msg puts msg regsub -all console_tcl_puts \ $errorInfo puts errorInfo error $msg } return $msg } if {$len} update } else { global errorCode errorInfo if {[catch "::console_tcl_puts $args" msg]} { regsub console_tcl_puts $msg puts msg regsub -all console_tcl_puts $errorInfo puts errorInfo error $msg } return $msg } } } if {!$class(WWW)} {; ## We exclude the reworking of unknown for the plugin ## Unknown changed to get output into Console window # unknown: # Invoked automatically whenever an unknown command is encountered. # Works through a list of "unknown handlers" that have been registered # to deal with unknown commands. Extensions can integrate their own # handlers into the "unknown" facility via "unknown_handle". # # If a handler exists that recognizes the command, then it will # take care of the command action and return a valid result or a # Tcl error. Otherwise, it should return "-code continue" (=2) # and responsibility for the command is passed to the next handler. # # Arguments: # args - A list whose elements are the words of the original # command, including the command name. proc ::unknown args { global unknown_handler_order unknown_handlers errorInfo errorCode # # Be careful to save error info now, and restore it later # for each handler. Some handlers generate their own errors # and disrupt handling. # set savedErrorCode $errorCode set savedErrorInfo $errorInfo if {![info exists unknown_handler_order] || \ ![info exists unknown_handlers]} { set unknown_handlers(tcl) tcl_unknown set unknown_handler_order tcl } foreach handler $unknown_handler_order { set status [catch {uplevel $unknown_handlers($handler) $args} result] if {$status == 1} { # # Strip the last five lines off the error stack (they're # from the "uplevel" command). # set new [split $errorInfo \n] set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] return -code $status -errorcode $errorCode \ -errorinfo $new $result } elseif {$status != 4} { return -code $status $result } set errorCode $savedErrorCode set errorInfo $savedErrorInfo } set name [lindex $args 0] return -code error "invalid command name \"$name\"" } # tcl_unknown: # Invoked when a Tcl command is invoked that doesn't exist in the # interpreter: # # 1. See if the autoload facility can locate the command in a # Tcl script file. If so, load it and execute it. # 2. If the command was invoked interactively at top-level: # (a) see if the command exists as an executable UNIX program. # If so, "exec" the command. # (b) see if the command requests csh-like history substitution # in one of the common forms !!, !<number>, or ^old^new. If # so, emulate csh's history substitution. # (c) see if the command is a unique abbreviation for another # command. If so, invoke the command. # # Arguments: # args - A list whose elements are the words of the original # command, including the command name. proc ::tcl_unknown args { global auto_noexec auto_noload env unknown_pending tcl_interactive global errorCode errorInfo # Save the values of errorCode and errorInfo variables, since they # may get modified if caught errors occur below. The variables will # be restored just before re-executing the missing command. set savedErrorCode $errorCode set savedErrorInfo $errorInfo set name [lindex $args 0] if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # if {[info exists unknown_pending($name)]} { return -code error "self-referential recursion in \"unknown\" for command \"$name\""; } set unknown_pending($name) pending; set ret [catch {auto_load $name} msg] unset unknown_pending($name); if {$ret != 0} { return -code $ret -errorcode $errorCode \ "error while autoloading \"$name\": $msg" } if {![array size unknown_pending]} { unset unknown_pending } if {$msg} { set errorCode $savedErrorCode set errorInfo $savedErrorInfo set code [catch {uplevel 1 $args} msg] if {$code == 1} { # # Strip the last five lines off the error stack (they're # from the "uplevel" command). # set new [split $errorInfo \n] set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] return -code error -errorcode $errorCode \ -errorinfo $new $msg } else { return -code $code $msg } } } if {[info level] == 1 && [string match {} [info script]] \ && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] if {[string compare $new ""]} { set errorCode $savedErrorCode set errorInfo $savedErrorInfo set redir "" if {[info commands console] == ""} { set redir ">&@stdout <@stdin" } return [uplevel exec $redir $new [lrange $args 1 end]] } } set errorCode $savedErrorCode set errorInfo $savedErrorInfo ## ## History substitution moved into EvalCmd ## set ret [catch {set cmds [info commands $name*]} msg] if {![string compare $name "::"]} { set name "" } if {$ret != 0} { return -code $ret -errorcode $errorCode \ "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" } if {[llength $cmds] == 1} { return [uplevel [lreplace $args 0 0 $cmds]] } if {[llength $cmds]} { if {$name == ""} { return -code error "empty command name \"\"" } else { return -code error \ "ambiguous command name \"$name\": [lsort $cmds]" } } } return -code continue } }; # end switch on proc unknown switch -glob $tcl_platform(platform) { win* { set META Alt } mac* { set META Command } default { set META Meta } } # ClipboardKeysyms -- # This procedure is invoked to identify the keys that correspond to # the "copy", "cut", and "paste" functions for the clipboard. # # Arguments: # copy - Name of the key (keysym name plus modifiers, if any, # such as "Meta-y") used for the copy operation. # cut - Name of the key used for the cut operation. # paste - Name of the key used for the paste operation. ;proc ClipboardKeysyms {copy cut paste} { bind Console <$copy> [namespace code {Copy %W}] bind Console <$cut> [namespace code {Cut %W}] bind Console <$paste> [namespace code {Paste %W}] } ;proc Cut w { if {[string match $w [selection own -displayof $w]]} { clipboard clear -displayof $w catch { clipboard append -displayof $w [selection get -displayof $w] if {[$w compare sel.first >= limit]} {$w delete sel.first sel.last} } } } ;proc Copy w { if {[string match $w [selection own -displayof $w]]} { clipboard clear -displayof $w catch {clipboard append -displayof $w [selection get -displayof $w]} } } ;proc Paste w { if { ![catch {selection get -displayof $w} tmp] || ![catch {selection get -displayof $w -type TEXT} tmp] || ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] } { if {[$w compare insert < limit]} {$w mark set insert end} $w insert insert $tmp $w see insert if {[string match *\n* $tmp]} {Eval $w} } } ## Get all Text bindings into Console foreach ev [bind Text] { bind Console $ev [namespace code [bind Text $ev]] } ## We don't want newline insertion bind Console <Control-Key-o> {} foreach {ev key} { <<Console_Prev>> <Key-Up> <<Console_Next>> <Key-Down> <<Console_NextImmediate>> <Control-Key-n> <<Console_PrevImmediate>> <Control-Key-p> <<Console_PrevSearch>> <Control-Key-r> <<Console_NextSearch>> <Control-Key-s> <<Console_Expand>> <Key-Tab> <<Console_ExpandFile>> <Key-Escape> <<Console_ExpandProc>> <Control-Shift-Key-P> <<Console_ExpandVar>> <Control-Shift-Key-V> <<Console_Tab>> <Control-Key-i> <<Console_Tab>> <Meta-Key-i> <<Console_Eval>> <Key-Return> <<Console_Eval>> <Key-KP_Enter> <<Console_Clear>> <Control-Key-l> <<Console_KillLine>> <Control-Key-k> <<Console_Transpose>> <Control-Key-t> <<Console_ClearLine>> <Control-Key-u> <<Console_SaveCommand>> <Control-Key-z> <<Console_Exit>> <Control-Key-q> <<Console_New>> <Control-Key-N> <<Console_Close>> <Control-Key-w> <<Console_About>> <Control-Key-A> <<Console_Help>> <Control-Key-H> <<Console_Find>> <Control-Key-F> } { event add $ev $key bind Console $key {} } catch {unset ev key} ## Redefine for Console what we need ## event delete <<Paste>> <Control-V> ClipboardKeysyms <Copy> <Cut> <Paste> bind Console <Insert> {catch {Insert %W [selection get -displayof %W]}} bind Console <Triple-1> {+ catch { eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] eval %W tag remove sel sel.last-1c %W mark set insert sel.first } } bind Console <<Console_Expand>> [namespace code { if {[%W compare insert > limit]} {Expand %W} break }] bind Console <<Console_ExpandFile>> [namespace code { if {[%W compare insert > limit]} {Expand %W path} break }] bind Console <<Console_ExpandProc>> [namespace code { if {[%W compare insert > limit]} {Expand %W proc} break }] bind Console <<Console_ExpandVar>> [namespace code { if {[%W compare insert > limit]} {Expand %W var} break }] bind Console <<Console_Tab>> [namespace code { if {[%W compare insert >= limit]} { Insert %W \t } }] bind Console <<Console_Eval>> [namespace code { Eval %W }] bind Console <Delete> { if {[string compare {} [%W tag nextrange sel 1.0 end]] \ && [%W compare sel.first >= limit]} { %W delete sel.first sel.last } elseif {[%W compare insert >= limit]} { %W delete insert %W see insert } } bind Console <BackSpace> { if {[string compare {} [%W tag nextrange sel 1.0 end]] \ && [%W compare sel.first >= limit]} { %W delete sel.first sel.last } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} { %W delete insert-1c %W see insert } } bind Console <Control-h> [bind Console <BackSpace>] bind Console <KeyPress> [namespace code { Insert %W %A }] bind Console <Control-a> { if {[%W compare {limit linestart} == {insert linestart}]} { tkTextSetCursor %W limit } else { tkTextSetCursor %W {insert linestart} } } bind Console <Control-d> { if {[%W compare insert < limit]} break %W delete insert } bind Console <<Console_KillLine>> { if {[%W compare insert < limit]} break if {[%W compare insert == {insert lineend}]} { %W delete insert } else { %W delete insert {insert lineend} } } bind Console <<Console_Clear>> [namespace code { _clear [winfo parent %W] }] bind Console <<Console_Prev>> [namespace code { if {[%W compare {insert linestart} != {limit linestart}]} { tkTextSetCursor %W [tkTextUpDownLine %W -1] } else { _event [winfo parent %W] -1 } }] bind Console <<Console_Next>> [namespace code { if {[%W compare {insert linestart} != {end-1c linestart}]} { tkTextSetCursor %W [tkTextUpDownLine %W 1] } else { _event [winfo parent %W] 1 } }] bind Console <<Console_NextImmediate>> [namespace code { _event [winfo parent %W] 1 }] bind Console <<Console_PrevImmediate>> [namespace code { _event [winfo parent %W] -1 }] bind Console <<Console_PrevSearch>> [namespace code { _event [winfo parent %W] -1 [CmdGet %W] }] bind Console <<Console_NextSearch>> [namespace code { _event [winfo parent %W] 1 [CmdGet %W] }] bind Console <<Console_Transpose>> { ## Transpose current and previous chars if {[%W compare insert > limit]} { tkTextTranspose %W } } bind Console <<Console_ClearLine>> { ## Clear command line (Unix shell staple) %W delete limit end } bind Console <<Console_SaveCommand>> [namespace code { ## Save command buffer (swaps with current command) savecommand %W }] catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }} catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }} catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }} catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }} bind Console <$META-d> { if {[%W compare insert >= limit]} { %W delete insert {insert wordend} } } bind Console <$META-BackSpace> { if {[%W compare {insert -1c wordstart} >= limit]} { %W delete {insert -1c wordstart} insert } } bind Console <$META-Delete> { if {[%W compare insert >= limit]} { %W delete insert {insert wordend} } } bind Console <ButtonRelease-2> { ## Try and get the default selection, then try and get the selection ## type TEXT, then try and get the clipboard if nothing else is available if { (!$tkPriv(mouseMoved) || $tk_strictMotif) && (![catch {selection get -displayof %W} tkPriv(junk)] || ![catch {selection get -displayof %W -type TEXT} tkPriv(junk)] || ![catch {selection get -displayof %W \ -selection CLIPBOARD} tkPriv(junk)]) } { if {[%W compare @%x,%y < limit]} { %W insert end $tkPriv(junk) } else { %W insert @%x,%y $tkPriv(junk) } if {[string match *\n* $tkPriv(junk)]} { namespace inscope ::Widget::Console { Eval %W } } } } ## ## End Console bindings ## ## ## Bindings for doing special things based on certain keys ## bind PostConsole <Key-parenright> [namespace code { if {[string compare \\ [%W get insert-2c]]} {MatchPair %W \( \) limit} }] bind PostConsole <Key-bracketright> [namespace code { if {[string compare \\ [%W get insert-2c]]} {MatchPair %W \[ \] limit} }] bind PostConsole <Key-braceright> [namespace code { if {[string compare \\ [%W get insert-2c]]} {MatchPair %W \{ \} limit} }] bind PostConsole <Key-quotedbl> [namespace code { if {[string compare \\ [%W get insert-2c]]} {MatchQuote %W limit} }] bind PostConsole <KeyPress> [namespace code { if {[string compare {} %A]} {TagProc %W} }] ## TagProc - tags a procedure in the console if it's recognized ## This procedure is not perfect. However, making it perfect wastes ## too much CPU time... Also it should check the existence of a command ## in whatever is the connected slave, not the master interpreter. ## ;proc TagProc w { upvar \#0 [namespace current]::[winfo parent $w] data if {!$data(-lightcmd)} return set exp "\[^\\]\[\[ \t\n\r\;{}\"\$]" set i [$w search -backwards -regexp $exp insert-1c limit-1c] if {[string compare {} $i]} {append i +2c} {set i limit} regsub -all {[[\\\?\*]} [$w get $i "insert-1c wordend"] {\\\0} c if {[string compare {} [EvalAttached info commands [list $c]]]} { $w tag add proc $i "insert-1c wordend" } else { $w tag remove proc $i "insert-1c wordend" } if {[string compare {} [EvalAttached info vars [list $c]]]} { $w tag add var $i "insert-1c wordend" } else { $w tag remove var $i "insert-1c wordend" } } ## MatchPair - blinks a matching pair of characters ## c2 is assumed to be at the text index 'insert'. ## This proc is really loopy and took me an hour to figure out given ## all possible combinations with escaping except for escaped \'s. ## It doesn't take into account possible commenting... Oh well. If ## anyone has something better, I'd like to see/use it. This is really ## only efficient for small contexts. # ARGS: w - console text widget # c1 - first char of pair # c2 - second char of pair # Calls: blink ## ;proc MatchPair {w c1 c2 {lim 1.0}} { upvar \#0 [namespace current]::[winfo parent $w] data if {!$data(-lightbrace) || $data(-blinktime)<100} return if {[string compare [set ix [$w search -back $c1 insert $lim]] {}]} { while {[string match {\\} [$w get $ix-1c]] && \ [string compare [set ix [$w search -back $c1 $ix-1c $lim]] {}]} {} set i1 insert-1c while {[string compare $ix {}]} { set i0 $ix set j 0 while {[string compare [set i0 [$w search $c2 $i0 $i1]] {}]} { append i0 +1c if {[string match {\\} [$w get $i0-2c]]} continue incr j } if {!$j} break set i1 $ix while {$j && [string compare \ [set ix [$w search -back $c1 $ix $lim]] {}]} { if {[string match {\\} [$w get $ix-1c]]} continue incr j -1 } } if {[string match {} $ix]} { set ix [$w index $lim] } } else { set ix [$w index $lim] } if {$data(-blinkrange)} { blink $w $data(-blinktime) $ix [$w index insert] } else { blink $w $data(-blinktime) $ix $ix+1c \ [$w index insert-1c] [$w index insert] } } ## MatchQuote - blinks between matching quotes. ## Blinks just the quote if it's unmatched, otherwise blinks quoted string ## The quote to match is assumed to be at the text index 'insert'. # ARGS: w - console text widget # Calls: blink ## ;proc MatchQuote {w {lim 1.0}} { upvar \#0 [namespace current]::[winfo parent $w] data if {!$data(-lightbrace) || $data(-blinktime)<100} return set i insert-1c set j 0 while {[string compare {} [set i [$w search -back \" $i $lim]]]} { if {[string match {\\} [$w get $i-1c]]} continue if {!$j} {set i0 $i} incr j } if {[expr $j%2]} { if {$data(-blinkrange)} { blink $w $data(-blinktime) $i0 [$w index insert] } else { blink $w $data(-blinktime) $i0 $i0+1c \ [$w index insert-1c] [$w index insert] } } else { blink $w $data(-blinktime) [$w index insert-1c] \ [$w index insert] } } ## blink - blinks between 2 indices for a specified duration. # ARGS: w - console text widget # delay - millisecs to blink for # args - indices of regions to blink # Outputs: blinks selected characters in $w ## ;proc blink {w delay args} { eval $w tag add blink $args after $delay eval $w tag remove blink $args return } ## Insert ## Insert a string into a text console at the point of the insertion cursor. ## If there is a selection in the text, and it covers the point of the ## insertion cursor, then delete the selection before inserting. # ARGS: w - text window in which to insert the string # s - string to insert (usually just a single char) # Outputs: $s to text widget ## ;proc Insert {w s} { if {[string match {} $s] || [string match disabled [$w cget -state]]} { return } if {[$w comp insert < limit]} { $w mark set insert end } catch { if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { $w delete sel.first sel.last } } $w insert insert $s $w see insert } ## Expand - # ARGS: w - text widget in which to expand str # type - type of expansion (path / proc / variable) # Calls: Expand(Pathname|Procname|Variable) # Outputs: The string to match is expanded to the longest possible match. # If data(-showmultiple) is non-zero and the user longest match # equaled the string to expand, then all possible matches are # output to stdout. Triggers bell if no matches are found. # Returns: number of matches found ## ## FIX: make namespace aware ;proc Expand {w {type ""}} { set exp "\[^\\]\[\[ \t\n\r{}\"\$]" set tmp [$w search -backwards -regexp $exp insert-1c limit-1c] if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit} if {[$w compare $tmp >= insert]} return set str [$w get $tmp insert] switch -glob $type { pa* { set res [ExpandPathname $str] } pr* { set res [ExpandProcname $str] } v* { set res [ExpandVariable $str] } default { set res {} foreach t {Pathname Procname Variable} { if {[string compare {} [set res [Expand$t $str]]]} break } } } set len [llength $res] if {$len} { $w delete $tmp insert $w insert $tmp [lindex $res 0] if {$len > 1} { upvar \#0 [namespace current]::[winfo parent $w] data if {$data(-showmultiple) && \ ![string compare [lindex $res 0] $str]} { puts stdout [lsort [lreplace $res 0 0]] } } } else { bell } return [incr len -1] } ## ExpandPathname - expand a file pathname based on $str ## This is based on UNIX file name conventions # ARGS: str - partial file pathname to expand # Calls: ExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches ## ;proc ExpandPathname str { set pwd [EvalAttached pwd] if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { return -code error $err } if {[catch {lsort -dict [EvalAttached [list glob [file tail $str]*]]} m]} { set match {} } else { if {[llength $m] > 1} { global tcl_platform if {[string match windows $tcl_platform(platform)]} { ## Windows is screwy because it's can be case insensitive set tmp [best_match [string tolower $m] \ [string tolower [file tail $str]]] } else { set tmp [best_match $m [file tail $str]] } if {[string match ?*/* $str]} { set tmp [file dirname $str]/$tmp } elseif {[string match /* $str]} { set tmp /$tmp } regsub -all { } $tmp {\\ } tmp set match [linsert $m 0 $tmp] } else { ## This may look goofy, but it handles spaces in path names eval append match $m if {[file isdir $match]} {append match /} if {[string match ?*/* $str]} { set match [file dirname $str]/$match } elseif {[string match /* $str]} { set match /$match } regsub -all { } $match {\\ } match ## Why is this one needed and the ones below aren't!! set match [list $match] } } EvalAttached [list cd $pwd] return $match } ## ExpandProcname - expand a tcl proc name based on $str # ARGS: str - partial proc name to expand # Calls: best_match # Returns: list containing longest unique match followed by all the # possible further matches ## ;proc ExpandProcname str { set match [EvalAttached [list info commands $str*]] if {[llength $match] > 1} { regsub -all { } [best_match $match $str] {\\ } str set match [linsert $match 0 $str] } else { regsub -all { } $match {\\ } match } return $match } ## ExpandVariable - expand a tcl variable name based on $str # ARGS: str - partial tcl var name to expand # Calls: best_match # Returns: list containing longest unique match followed by all the # possible further matches ## ;proc ExpandVariable str { if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { ## Looks like they're trying to expand an array. set match [EvalAttached [list array names $ary $str*]] if {[llength $match] > 1} { set vars $ary\([best_match $match $str] foreach var $match {lappend vars $ary\($var\)} return $vars } else {set match $ary\($match\)} ## Space transformation avoided for array names. } else { set match [EvalAttached [list info vars $str*]] if {[llength $match] > 1} { regsub -all { } [best_match $match $str] {\\ } str set match [linsert $match 0 $str] } else { regsub -all { } $match {\\ } match } } return $match } ## resource - re'source's this script into current console ## Meant primarily for my development of this program. It follows ## links until the ultimate source is found. ## set class(SCRIPT) [info script] if {!$class(WWW)} { while {[string match link [file type $class(SCRIPT)]]} { set link [file readlink $class(SCRIPT)] if {[string match relative [file pathtype $link]]} { set class(SCRIPT) [file join \ [file dirname $class(SCRIPT)] $link] } else { set class(SCRIPT) $link } } catch {unset link} if {[string match relative [file pathtype $class(SCRIPT)]]} { set class(SCRIPT) [file join [pwd] $class(SCRIPT)] } } ;proc resource {} { upvar \#0 [namespace current] class uplevel \#0 [list source $class(SCRIPT)] } }; # end namespace ::Widget::Console |
Added library/digraph.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | # digraph.tcl -- # # This file defines the bindings for Tk widgets to provide # procedures that allow the input of the extended latin charset # (often referred to as digraphs). # # Copyright (c) 1998 Jeffrey Hobbs package require Tk 8 namespace eval ::digraph {; namespace export -clear digraph variable wid array set char { `A � A` � `a � a` � 'A � A' � 'a � a' � ^A � A^ � ^a � a^ � ~A � A~ � ~a � a~ � \"A � A\" � \"a � a\" � *A � A* � *a � a* � AE � ae � ,C � C, � ,c � c, � -D � D- � -d � d- � `E � E` � `e � e` � 'E � E' � 'e � e' � ^E � E^ � ^e � e^ � \"E � E\" � \"e � e\" � `I � I` � `i � i` � 'I � I' � 'i � i' � ^I � I^ � ^i � i^ � \"I � I\" � \"i � i\" � ~N � N~ � ~n � n~ � `O � O` � `o � o` � 'O � O' � 'o � o' � ^O � O^ � ^o � o^ � ~O � O~ � ~o � o~ � \"O � O\" � \"o � o\" � /O � O/ � /o � o/ � `U � U` � `u � u` � 'U � U' � 'u � u' � ^U � U^ � ^u � u^ � \"U � U\" � \"u � u\" � 'Y � 'y � \"y � y\" � ss � !! � || � \"\" � ,, � c/ � /c � C/ � /C � l- � -l � L- � -L � ox � xo � OX � XO � y- � -y � Y- � -Y � co � oc � CO � OC � << � >> � ro � or � RO � OR � -^ � ^- � -+ � +- � ^2 � 2^ � ^3 � 3^ � ,u � u, � .^ � ^. � P| � |P � p| � |p � 14 � 41 � 12 � 21 � 34 � 43 � ?? � xx � } proc translate {c} { variable char if {[info exists char($c)]} {return $char($c)} return $c } proc insert {w type a k} { variable wid if {[info exists wid($w)]} { # This means we have already established the echar binding if {[info exists wid(FIRST.$w)]} { # This means that we are in the middle of setting an echar # By default, it will be these two chars set char [translate "$wid(FIRST.$w)$a"] switch -exact $type { TkConsole { tkConInsert $w $char } Text { tkTextInsert $w $char } Entry { tkEntryInsert $w $char } Table { $w insert active insert $char } default { catch { $w insert $char } } } bind $w <KeyPress> $wid($w) unset wid($w) unset wid(FIRST.$w) } else { # This means we are getting the first part of the echar if {[string compare $a {}]} { set wid(FIRST.$w) $a } else { # For Text widget, after the Multi_key, # it does some weird things to Tk's keysym translations switch -glob $k { apostrophe {set wid(FIRST.$w) "'"} grave {set wid(FIRST.$w) "`"} comma {set wid(FIRST.$w) ","} quotedbl {set wid(FIRST.$w) "\""} asciitilde {set wid(FIRST.$w) "~"} asciicurcum {set wid(FIRST.$w) "^"} Control* - Shift* - Caps_Lock - Alt* - Meta* { # ignore this anomaly return } default { # bogus first char, just end state transition now bind $w <KeyPress> $wid($w) unset wid($w) } } } } } else { # Cache the widget's binding, it doesn't matter if there isn't one # If the class has a special binding, then this could be redone set wid($w) [bind $w <KeyPress>] # override the binding bind $w <KeyPress> [namespace code \ "insert %W [list $type] %A %K; break"] } } # w is either a specific widget, or a class proc digraph {w} { if {[winfo exists $w]} { # it is a specific widget } else { # it is a class of widgets if {[string compare [info commands digraph$w] {}]} { digraph$w } else { bind $w <<Digraph>> [namespace code \ "insert %W [list $w] %A %K; break"] } } } proc digraphText args { bind Text <<Digraph>> [namespace code { insert %W Text %A %K; break }] bind Text <Key-Escape> {} } proc digraphEntry args { bind Entry <<Digraph>> [namespace code { insert %W Entry %A %K; break }] bind Entry <Key-Escape> {} } proc digraphTable args { bind Table <<Digraph>> [namespace code { insert %W Table %A %K; break }] #bind Table <Key-Escape> {} } proc digraphTkConsole args { bind TkConsole <<Digraph>> [namespace code { insert %W TkConsole %A %K break } ] event delete <<TkCon_ExpandFile>> <Key-Escape> } }; # end creation of digraph namespace # THE EVENT YOU CHOOSE IS IMPORTANT - You should also make sure that that # event is not bound to the class already (for example, most bind <Escape> # to {# nothing}, but Table uses it for the reread and TkConsole uses it # for TkCon_ExpandFile). The Sun <Multi_key> works already, but you might # want to define special state keys event add <<Digraph>> <Key-Escape> <Mode_switch> |
Added library/hierarchy.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 | ## ## Layout routines taken from oooold code, author unkown. ## Copyright 1995-1998 Jeffrey Hobbs, [email protected] ## ## Last Update: 28 June 1997 ## package require Widget 2.0 package provide Hierarchy 2.0 ##----------------------------------------------------------------------- ## PROCEDURE(S) ## hierarchy, hierarchy_dir, hierarchy_widget ## ## ARGUMENTS && DESCRIPTION ## ## hierarchy <window pathname> <options> ## Implements a hierarchical listbox ## hierarchy_dir <window pathname> <options> ## Implements a hierarchical listbox using a directory view structure ## for the default methods ## hierarchy_widget <window pathname> <options> ## Implements a hierarchical listbox using a widget view structure ## for the default methods ## ## OPTIONS ## (Any canvas option may be used with a hierarchy) ## ## -autoscrollbar TCL_BOOLEAN DEFAULT: 1 ## Determines whether scrollbars automagically pop-up or ## are permanently there. ## ## -browsecmd procedure DEFAULT: noop ## A command which the widget will execute when the node is expanded ## to retrieve the children of a node. The widget and node path are ## appended to the command as a list of node names which ## form a path to the node from the root. Thus the first ## element of this list will always be the root node. ## ## -command procedure DEFAULT: noop ## A command which the widget will execute when the node is toggled. ## The name of the widget, the node path, and whether the children of ## the node are showing (0/1) is appended to the procedure args. ## ## -decoration TCL_BOOLEAN DEFAULT: 1 ## If this is true, the "tree" lines are drawn. ## ## -expand # DEFAULT: 1 ## an integer value for an initial depth to expand to. ## ## -font fontname DEFAULT: fixed ## The default font used for the text. ## ## -foreground color DEFAULT: black ## The default foreground color used for text of unselected nodes. ## ## -ipad # DEFAULT: 3 ## The internal space added between the image and the text for a ## given node. ## ## -nodelook procedure DEFAULT: noop ## A command the widget will execute to get the look of a node. ## The node is appended to the command as a list of ## node-names which form a path to the node from the root. ## Thus the first element of this list will always be the ## root node. Also appended is a ## boolean value which indicates whether the node's children ## are currently displayed. This allows the node's ## look to change if it is "opened" or "closed". ## ## This command must return a 4-tuple list containing: ## 0. the text to display at the node ## 1. the font to use for the text ## 2. an image to display ## 3. the foreground color to use for the node ## If no font (ie. {}) is specified then ## the value from -font is used. If no image is specified ## then no image is displayed. ## The default is a command to which produces a nice look ## for a file manager. ## ## -paddepth # DEFAULT: 12 ## The indent space added for child branches. ## ## -padstack # DEFAULT: 2 ## The space added between two rows ## ## -root rootname DEFAULT: {} ## The name of the root node of the tree. Each node ## name must be unique amongst the children of each node. ## ## -selectbackground color DEFAULT: red ## The default background color used for the text of selected nodes. ## ## -selectmode (single|browse|multiple) DEFAULT: browse ## Like listbox modes, "multiple" is a mix of multiple && extended. ## ## -showall TCL_BOOLEAN DEFAULT: 0 ## For directory nodelook, also show Unix '.' (hidden) files/dirs. ## ## -showfiles TCL_BOOLEAN DEFAULT: 0 ## Show files as well as directories. ## ## -showparent string DEFAULT: {} ## For hierarchy_dir nodelook, if string != {}, then it will show that ## string which will reset the root node to its parent. ## ## METHODS ## These are the methods that the hierachical listbox object recognizes. ## (ie - hierachy .h ; .h <method> <args>) ## Any unique substring is acceptable ## ## configure ?option? ?value option value ...? ## cget option ## Standard tk widget routines. ## ## close index ## Closes the specified index (will trigger -command). ## ## curselection ## Returns the indices of the selected items. This differs from the ## listbox method because indices here have no implied order. ## ## get index ?index ...? ## Returns the node paths of the items referenced. Ranges are not ## allowed. Index specification is like that allowed by the index ## method. ## ## qget index ?index ...? ## As above, but the indices must be that of the item (as returned ## by the index or curselection method). ## ## index index ## Returns the hierarchy numerical index of the item (the numerical ## index has no implied order relative to the list items). index ## may be of the form: ## ## number - Specifies the element as a numerical index. ## root - specifies the root item. ## string - Specifis an item that has that text in it's node. ## @x,y - Indicates the element that covers the point in ## the listbox window specified by x and y (in pixel ## coordinates). If no element covers that point, ## then the closest element to that point is used. ## ## open index ## Opens the specified index (will trigger -command). ## ## see index ## Ensures that the item specified by the index is viewable. ## ## refresh ## Refreshes all open nodes ## ## selection option arg ## This works like the listbox selection method with the following ## exceptions: ## ## The selection clear option can take multiple indices, but not a range. ## No arguments to clear means clear all the selected elements. ## ## The selection set option can take multiple indices, but not a range. ## The key word 'all' sets the selection for all elements. ## ## size ## Returns the number of items in the hierarchical listbox. ## ## toggle index ## Toggles (open or closed) the item specified by index ## (triggers -command). ## ## BINDINGS ## Most Button-1 bindings on the hierarchy work in the same manner ## as those for the listbox widget, as defined by the selectmode. ## Those that vary are listed below: ## ## <Double-Button-1> ## Toggles a node in the hierarchy ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ##----------------------------------------------------------------------- # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc Hierarchy args {} proc hierarchy args {} ## In general, we cannot use $data(basecmd) in the construction, but the ## scrollbar commands won't be called until after it really exists as a ## proper command widget create Hierarchy -type frame -base canvas -components { {base canvas canvas {-relief sunken -bd 1 -highlightthickness 1 \ -yscrollcommand [list $data(yscrollbar) set] \ -xscrollcommand [list $data(xscrollbar) set]}} {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\ -command [list $data(basecmd) xview]}} {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\ -command [list $data(basecmd) yview]}} } -options { {-autoscrollbar autoScrollbar AutoScrollbar 1} {-browsecmd browseCmd BrowseCmd {}} {-command command Command {}} {-decoration decoration Decoration 1} {-expand expand Expand 1} {-font font Font fixed} {-foreground foreground Foreground black} {-ipad ipad Ipad 3} {-nodelook nodeLook NodeLook {}} {-paddepth padDepth PadDepth 12} {-padstack padStack PadStack 2} {-root root Root {}} {-selectmode selectMode SelectMode browse} {-selectbackground selectBackground SelectBackground red} {-state state State normal} {-showall showAll ShowAll 0} {-showparent showParent ShowParent {}} {-showfiles showFiles ShowFiles 0} } proc hierarchy_dir {w args} { uplevel [list hierarchy $w -root [pwd] \ -nodelook {namespace inscope ::Widget::Hierarchy FileLook} \ -command {namespace inscope ::Widget::Hierarchy FileActivate} \ -browsecmd {namespace inscope ::Widget::Hierarchy FileList}] \ $args } proc hierarchy_widget {w args} { uplevel [list hierarchy $w -root . \ -nodelook {namespace inscope ::Widget::Hierarchy WidgetLook} \ -command {namespace inscope ::Widget::Hierarchy WidgetActivate} \ -browsecmd {namespace inscope ::Widget::Hierarchy WidgetList}] \ $args } if {[string match windows $tcl_platform(platform)] && \ ![catch {package require registry}]} { proc hierarchy_registry {w args} { uplevel [list hierarchy $w -root "Localhost" \ -nodelook {namespace inscope ::Widget::Hierarchy RegistryLook} \ -command {namespace inscope ::Widget::Hierarchy RegistryAct} \ -browsecmd {namespace inscope ::Widget::Hierarchy RegistryList}] \ $args } } namespace eval ::Widget::Hierarchy {; ;proc construct w { upvar \#0 [namespace current]::$w data ## Private variables array set data [list \ hasnodelook 0 \ halfpstk [expr $data(-padstack)/2] \ width 400 \ ] grid $data(canvas) $data(yscrollbar) -sticky news grid $data(xscrollbar) -sticky ew grid columnconfig $w 0 -weight 1 grid rowconfig $w 0 -weight 1 bind $data(canvas) <Configure> [namespace code [list Resize $w %w %h]] } ;proc init w { upvar \#0 [namespace current]::$w data set data(:$data(-root),showkids) 0 ExpandNodeN $w $data(-root) $data(-expand) if {[catch {$w see $data(-root)}]} { $data(basecmd) configure -scrollregion {0 0 1 1} } } ;proc configure {w args} { upvar \#0 [namespace current]::$w data set truth {^(1|yes|true|on)$} array set config { resize 0 root 0 showall 0 } foreach {key val} $args { switch -- $key { -autoscrollbar { set val [regexp -nocase $truth $val] if {$val} { set config(resize) 1 } else { grid $data(xscrollbar) grid $data(yscrollbar) } } -decoration { set val [regexp -nocase $truth $val] } -padstack { set data(halfpstk) [expr {$val/2}] } -nodelook { ## We set this special bool val because it saves some ## computation in ExpandNode, a deeply nested proc set data(hasnodelook) [string compare $val {}] } -root { if {[info exists data(:$data(-root),showkids)]} { ## All data about items and selection should be ## cleared and the items deleted foreach name [concat [array names data :*] \ [array names data S,*]] {unset data($name)} $data(basecmd) delete all set data(-root) $val set config(root) 1 ## Avoid setting data($key) below continue } } -selectbackground { foreach i [array names data S,*] { $data(basecmd) itemconfigure [string range $i 2 end] \ -fill $val } } -state { if {![regexp {^(normal|disabled)$} $val junk val]} { return -code error "bad state value \"$val\":\ must be normal or disabled" } } -showall - -showfiles { set val [regexp -nocase $truth $val] if {$val == $data($key)} continue set config(showall) 1 } } set data($key) $val } if {$config(root)} { set data(:$val,showkids) 0 ExpandNodeN $w $val $data(-expand) } elseif {$config(showall) && [info exists data(:$data(-root),showkids)]} { _refresh $w } elseif {$config(resize)} { Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] } } ## Cryptic source code arguments explained: ## (these, or a similar form, might appear as variables later) ## np == node path ## cnp == changed np ## knp == kids np ## xcnp == extra cnp ;proc _index { w idx } { upvar \#0 [namespace current]::$w data set c $data(basecmd) if {[string match all $idx]} { return [$c find withtag box] } elseif {[regexp {^(root|anchor)$} $idx]} { return [$c find withtag box:$data(-root)] } foreach i [$c find withtag $idx] { if {[string match rec* [$c type $i]]} { return $i } } if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} { return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text] } foreach i [$c find withtag box:[lindex $idx 0]] { return $i } return -code error "bad hierarchy index \"$idx\":\ must be current, @x,y, a number, or a node name" } ;proc _selection { w args } { if {[string match {} $args]} { return -code error \ "wrong \# args: should be \"$w selection option args\"" } upvar \#0 [namespace current]::$w data set err [catch {_index $w [lindex $args 1]} idx] switch -glob -- [lindex $args 0] { an* { ## anchor ## stubbed out - too complicated to support } cl* { ## clear set c $data(basecmd) if {$err} { foreach arg [array names data S,*] { unset data($arg) } $c itemconfig box -fill {} } else { catch {unset data(S,$idx)} $c itemconfig $idx -fill {} foreach idx [lrange $args 2 end] { if {[catch {_index $w $idx} idx]} { catch {unset data(S,$idx)} $c itemconfig $idx -fill {} } } } } in* { ## includes if {$err} { if {[llength $args]==2} { return -code error $idx } else { return -code error "wrong \# args:\ should be \"$w selection includes index\"" } } return [info exists data(S,$idx)] } se* { ## set if {$err} { if {[string compare {} $args]} return return -code error "wrong \# args:\ should be \"$w selection set index ?index ...?\"" } else { set c $data(basecmd); set col $data(-selectbackground) if {[string match all [lindex $args 1]]} { foreach i $idx { set data(S,$i) 1 } $c itemconfig box -fill $col } else { set data(S,$idx) 1 $c itemconfig $idx -fill $col foreach idx [lrange $args 2 end] { if {![catch {_index $w $idx} idx]} { set data(S,$idx) 1 $c itemconfig $idx -fill $col } } } } } default { return -code error "bad selection option \"[lindex $args 0]\":\ must be clear, includes, set" } } } ;proc _curselection {w} { upvar \#0 [namespace current]::$w data set res {} foreach i [array names data S,*] { lappend res [string range $i 2 end] } return $res } ;proc _get {w args} { upvar \#0 [namespace current]::$w data set nps {} foreach arg $args { if {![catch {_index $w $arg} idx] && \ [string compare {} $idx]} { set tags [$data(basecmd) gettags $idx] if {[set i [lsearch -glob $tags box:*]]>-1} { lappend nps [string range [lindex $tags $i] 4 end] } } } return $nps } ;proc _qget {w args} { upvar \#0 [namespace current]::$w data ## Quick get. Avoids expensive _index call set nps {} foreach arg $args { set tags [$data(basecmd) itemcget $arg -tags] if {[set i [lsearch -glob $tags box:*]]>-1} { lappend nps [string range [lindex $tags $i] 4 end] } } return $nps } ;proc _see {w args} { upvar \#0 [namespace current]::$w data if {[catch {_index $w $args} idx]} { return -code error $idx } elseif {[string compare {} $idx]} { set c $data(basecmd) foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] { set stk [lindex [$c cget -scrollregion] 3] set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0] } $c yview moveto $pos } } ;proc _refresh {w} { upvar \#0 [namespace current]::$w data array set expanded [array get data ":*,showkids"] foreach i [concat [array names data :*] \ [array names data S,*]] {unset data($i)} $data(basecmd) delete all ## -dec makes it sort in root-first order foreach i [lsort -ascii -decreasing [array names expanded]] { if {$expanded($i)} { regexp {^:(.*),showkids$} $i junk np ## Quick way to remove the last element of a list set prnt [lreplace $np end end] ## checks to get rid of dead, previously opened nodes if {[string match {} $prnt] || ([info exists data(:$prnt,kids)] \ && [lsearch -exact $data(:$prnt,kids) \ [lindex $np end]] != -1)} { set data($i) 0 ExpandNode $w $np } } } Redraw $w $data(-root) Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] } ;proc _size {w} { upvar \#0 [namespace current]::$w data return [llength [$data(basecmd) find withtag box]] } ## This will be the one called by <Double-Button-1> on the canvas, ## if -state is normal, so we have to make sure that $w is correct. ## ;proc _toggle { w index } { toggle $w $index toggle } ;proc _close { w index } { toggle $w $index close } ;proc _open { w index } { toggle $w $index open } ;proc toggle { w index which } { if {[string compare Hierarchy [winfo class $w]]} { set w [winfo parent $w] } upvar \#0 [namespace current]::$w data if {[string match {} [set np [_get $w $index]]]} return set np [lindex $np 0] set old [$data(basecmd) cget -cursor] $data(basecmd) config -cursor watch update switch $which { close { CollapseNodeAll $w $np } open { ExpandNodeN $w $np 1 } toggle { if {$data(:$np,showkids)} { CollapseNodeAll $w $np } else { ExpandNodeN $w $np 1 } } } if {[string compare {} $data(-command)]} { uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)] } $data(basecmd) config -cursor $old return } ;proc Resize { w wid hgt } { upvar \#0 [namespace current]::$w data set c $data(basecmd) if {[string compare {} [set box [$c bbox image text]]]} { set X [lindex $box 2] set Y [lindex $box 3] if {$data(-autoscrollbar)} { ## We will have to disable the Configure event temporarily, to ## prevent looping due to a quirk in geometry management where ## adding/removing the scrollbar changes the widget size. set W $data(canvas) set bind [bind $W <Configure>] bind $W <Configure> {} if {$wid>$X} { set X $wid grid remove $data(xscrollbar) } else { grid $data(xscrollbar) } if {$hgt>$Y} { set Y $hgt grid remove $data(yscrollbar) } else { grid $data(yscrollbar) } after 100 [list bind $W <Configure> $bind] } $c config -scrollregion "0 0 $X $Y" ## This makes full width highlight boxes ## data(width) is the default width of boxes if {$X>$data(width)} { set data(width) $X foreach b [$c find withtag box] { foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 } } } } elseif {$data(-autoscrollbar)} { grid remove $data(xscrollbar) $data(yscrollbar) } } ;proc CollapseNodeAll { w np } { if {[CollapseNode $w $np]} { upvar \#0 [namespace current]::$w data Redraw $w $np DiscardChildren $w $np Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] } } ;proc ExpandNodeN { w np n } { upvar \#0 [namespace current]::$w data if {[ExpandNodeN_aux $w $np $n] || \ ([string compare $data(-root) {}] && \ ![string compare $data(-root) $np])} { Redraw $w $np Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] } } ;proc ExpandNodeN_aux { w np n } { if {![ExpandNode $w $np]} { return 0 } if {$n==1} { return 1 } incr n -1 upvar \#0 [namespace current]::$w data foreach k $data(:$np,kids) { ExpandNodeN_aux $w "$np [list $k]" $n } return 1 } ######################################################################## ## ## Private routines to collapse and expand a single node w/o redrawing ## Most routines return 0/1 to indicate if any change has occurred ## ######################################################################## ;proc ExpandNode { w np } { upvar \#0 [namespace current]::$w data if {$data(:$np,showkids)} { return 0 } set data(:$np,showkids) 1 if {![info exists data(:$np,kids)]} { if {[string compare $data(-browsecmd) {}]} { set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]] } else { set data(:$np,kids) {} } } if $data(hasnodelook) { set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]] } else { set data(:$np,look) {} } if {[string match {} $data(:$np,kids)]} { ## This is needed when there are no kids to make sure the ## look of the node will be updated appropriately foreach {txt font img fg} $data(:$np,look) { lappend tags box:$np box $np set c $data(basecmd) if {[string compare $img {}]} { ## Catch just in case the image doesn't exist catch { $c itemconfigure img:$np -image $img lappend tags $img } } if {[string compare $txt {}]} { if {[string match {} $font]} { set font $data(-font) } if {[string match {} $fg]} { set fg $data(-foreground) } $c itemconfigure txt:$np -fill $fg -text $txt -font $font ## FIX: use [list txt: $txt] instead of $txt ## Here and in recompute, otherwise if the name of ## the text is an existing tag, we get an error if {[string compare $np $txt]} { lappend tags $txt } } $c itemconfigure box:$np -tags $tags ## We only want to go through once break } return 0 } foreach k $data(:$np,kids) { set knp "$np [list $k]" ## Check to make sure it doesn't already exist, ## in case we are refreshing the node or something if {![info exists data(:$knp,showkids)]} { set data(:$knp,showkids) 0 } if $data(hasnodelook) { set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]] } else { set data(:$knp,look) {} } } return 1 } ;proc CollapseNode { w np } { upvar \#0 [namespace current]::$w data if {!$data(:$np,showkids)} { return 0 } set data(:$np,showkids) 0 if {[string match {} $data(:$np,kids)]} { return 0 } if {[string compare $data(-nodelook) {}]} { set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]] } else { set data(:$np,look) {} } foreach k $data(:$np,kids) { CollapseNode $w "$np [list $k]" } return 1 } ;proc DiscardChildren { w np } { upvar \#0 [namespace current]::$w data if {[info exists data(:$np,kids)]} { foreach k $data(:$np,kids) { set knp "$np [list $k]" $data(basecmd) delete img:$knp txt:$knp box:$knp foreach i {showkids look stkusg stack iwidth offset} { catch {unset data(:$knp,$i)} } DiscardChildren $w $knp } unset data(:$np,kids) } } ## REDRAW mechanism ## 2 parts: recompute offsets of all children from changed node path ## then redraw children based on their offsets and look ## ;proc Redraw { w cnp } { upvar \#0 [namespace current]::$w data set c $data(basecmd) # When a node changes, the positions of a whole lot of things # change. The size of the scroll region also changes. $c delete decor # Calculate the new offset locations of everything Recompute $w $data(-root) [lrange $cnp 1 end] # Next recursively move all the bits around to their correct positions. # We choose an initial point (4,4) to begin at. Redraw_aux $w $data(-root) 4 4 # Necessary to make sure find closest gets the right item # ordering: image > text > box after idle "catch { [list $c] raise image text; [list $c] lower box text }" } ## RECOMPUTE recurses through the tree working out the relative offsets ## of children from their parents in terms of stack values. ## ## "cnp" is either empty or a node name which indicates where the only ## changes have occured in the hierarchy since the last call to Recompute. ## This is used because when a node is toggled on/off deep in the ## hierarchy then not all the positions of items need to be recomputed. ## The only ones that do are everything below the changed node (of ## course), and also everything which might depend on the stack usage of ## that node (i.e. everything above it). Specifically the usages of the ## changed node's siblings do *not* need to be recomputed. ## ;proc Recompute { w np cnp } { upvar \#0 [namespace current]::$w data # If the cnp now has only one element then # it must be one of the children of the current node. # We do not need to Recompute the usages of its siblings if it is. set cnode_is_child [expr {[llength $cnp]==1}] if {$cnode_is_child} { set cnode [lindex $cnp 0] } else { set xcnp [lrange $cnp 1 end] } # Run through the children, recursively calculating their usage of # stack real-estate, and allocating an intial placement for each child # # Values do not need to be recomputed for siblings of the changed # node and their descendants. For the cnode itself, in the # recursive call we set the value of cnode to {} to prevent # any further cnode checks. set children_stack 0 if {$data(:$np,showkids)} { foreach k $data(:$np,kids) { set knp "$np [list $k]" set data(:$knp,offset) $children_stack if {$cnode_is_child && [string match $cnode $k]} { set data(:$knp,stkusg) [Recompute $w $knp {}] } elseif {!$cnode_is_child} { set data(:$knp,stkusg) [Recompute $w $knp $xcnp] } incr children_stack $data(:$knp,stkusg) incr children_stack $data(-padstack) } } ## Make the image/text if they don't exist. ## Positioning occurs in Redraw_aux. ## And calculate the stack usage of our little piece of the world. set img_height 0; set img_width 0; set txt_width 0; set txt_height 0 foreach {txt font img fg} $data(:$np,look) { lappend tags box:$np box $np set c $data(basecmd) if {[string compare $img {}]} { if {[string match {} [$c find withtag img:$np]]} { $c create image 0 0 -anchor nw -tags [list img:$np image] } ## Catch just in case the image doesn't exist catch { $c itemconfigure img:$np -image $img lappend tags $img foreach {x y img_width img_height} [$c bbox img:$np] { incr img_width -$x; incr img_height -$y } } } if {[string compare $txt {}]} { if {[string match {} [$c find withtag txt:$np]]} { $c create text 0 0 -anchor nw -tags [list txt:$np text] } if {[string match {} $font]} { set font $data(-font) } if {[string match {} $fg]} { set fg $data(-foreground) } $c itemconfigure txt:$np -fill $fg -text $txt -font $font if {[string compare $np $txt]} { lappend tags $txt } foreach {x y txt_width txt_height} [$c bbox txt:$np] { incr txt_width -$x; incr txt_height -$y } } if {[string match {} [$c find withtag box:$np]]} { $c create rect 0 0 1 1 -tags [list box:$np box] -outline {} } $c itemconfigure box:$np -tags $tags ## We only want to go through this once break } set stack [expr {$txt_height>$img_height?$txt_height:$img_height}] # Now reposition the children downward by "stack" set overall_stack [expr {$children_stack+$stack}] if {$data(:$np,showkids)} { set off [expr {$stack+$data(-padstack)}] foreach k $data(:$np,kids) { set knp "$np [list $k]" incr data(:$knp,offset) $off } } # remember some facts for locating the image and drawing decor array set data [list :$np,stack $stack :$np,iwidth $img_width] return $overall_stack } ;proc Redraw_aux {w np deppos stkpos} { upvar \#0 [namespace current]::$w data set c $data(basecmd) $c coords img:$np $deppos $stkpos $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos $c coords box:$np 0 [expr {$stkpos-$data(halfpstk)}] \ $data(width) [expr {$stkpos+$data(:$np,stack)+$data(halfpstk)}] if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return set minkid_stkpos 100000 set maxkid_stkpos 0 set bar_deppos [expr {$deppos+$data(-paddepth)/2}] set kid_deppos [expr {$deppos+$data(-paddepth)}] foreach k $data(:$np,kids) { set knp "$np [list $k]" set kid_stkpos [expr {$stkpos+$data(:$knp,offset)}] Redraw_aux $w $knp $kid_deppos $kid_stkpos if {$data(-decoration)} { if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos} set kid_stkpos [expr {$kid_stkpos+$data(:$knp,stack)/2}] if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos} $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \ -width 1 -tags decor } } if {$data(-decoration)} { $c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \ -width 1 -tags decor } } ## ## DEFAULT BINDINGS FOR HIERARCHY ## ## Since we give no border to the frame, all Hierarchy bindings ## will always register on the canvas widget ## bind Hierarchy <Double-Button-1> { set w [winfo parent %W] if {[string match normal [$w cget -state]]} { $w toggle @%x,%y } } bind Hierarchy <ButtonPress-1> { if {[winfo exists %W]} { namespace eval ::Widget::Hierarchy \ [list BeginSelect [winfo parent %W] @%x,%y] } } bind Hierarchy <B1-Motion> { set tkPriv(x) %x set tkPriv(y) %y namespace eval ::Widget::Hierarchy [list Motion [winfo parent %W] @%x,%y] } bind Hierarchy <ButtonRelease-1> { tkCancelRepeat } bind Hierarchy <Shift-1> [namespace code \ { BeginExtend [winfo parent %W] @%x,%y }] bind Hierarchy <Control-1> [namespace code \ { BeginToggle [winfo parent %W] @%x,%y }] bind Hierarchy <B1-Leave> { set tkPriv(x) %x set tkPriv(y) %y namespace eval ::Widget::Hierarchy [list AutoScan [winfo parent %W]] } bind Hierarchy <B1-Enter> { tkCancelRepeat } ## Should reserve L/R U/D for traversing nodes bind Hierarchy <Up> { %W yview scroll -1 units } bind Hierarchy <Down> { %W yview scroll 1 units } bind Hierarchy <Left> { %W xview scroll -1 units } bind Hierarchy <Right> { %W xview scroll 1 units } bind Hierarchy <Control-Up> { %W yview scroll -1 pages } bind Hierarchy <Control-Down> { %W yview scroll 1 pages } bind Hierarchy <Control-Left> { %W xview scroll -1 pages } bind Hierarchy <Control-Right> { %W xview scroll 1 pages } bind Hierarchy <Prior> { %W yview scroll -1 pages } bind Hierarchy <Next> { %W yview scroll 1 pages } bind Hierarchy <Control-Prior> { %W xview scroll -1 pages } bind Hierarchy <Control-Next> { %W xview scroll 1 pages } bind Hierarchy <Home> { %W xview moveto 0 } bind Hierarchy <End> { %W xview moveto 1 } bind Hierarchy <Control-slash> [namespace code \ { SelectAll [winfo parent %W] }] bind Hierarchy <Control-backslash> [namespace code \ { [winfo parent %W] selection clear }] bind Hierarchy <2> { set tkPriv(x) %x set tkPriv(y) %y %W scan mark %x %y } bind Hierarchy <B2-Motion> { %W scan dragto $tkPriv(x) %y } ## BINDING HELPER PROCEDURES ## ## These are mostly mirrored from the Listbox class bindings. ## ## Some of these are hacked up to be more efficient by making calls ## that require forknowledge of the megawidget structure. ## # BeginSelect -- # # This procedure is typically invoked on button-1 presses. It begins # the process of making a selection in the hierarchy. Its exact behavior # depends on the selection mode currently in effect for the hierarchy; # see the Motif documentation for details. # # Arguments: # w - The hierarchy widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. ;proc BeginSelect {w el} { global tkPriv if {[catch {_index $w $el} el]} return _selection $w clear _selection $w set $el set tkPriv(hierarchyPrev) $el } # Motion -- # # This procedure is called to process mouse motion events while # button 1 is down. It may move or extend the selection, depending # on the hierarchy's selection mode. # # Arguments: # w - The hierarchy widget. # el - The element under the pointer (must be a number). ;proc Motion {w el} { global tkPriv if {[catch {_index $w $el} el] || \ [string match $el $tkPriv(hierarchyPrev)]} return switch [_cget $w -selectmode] { browse { _selection $w clear 0 end if {![catch {_selection $w set $el}]} { set tkPriv(hierarchyPrev) $el } } multiple { ## This happens when a double-1 occurs and all the index boxes ## have changed if {[catch {_selection $w includes \ $tkPriv(hierarchyPrev)} inc]} { set tkPriv(hierarchyPrev) [_index $w $el] return } if {$inc} { _selection $w set $el } else { _selection $w clear $el } set tkPriv(hierarchyPrev) $el } } } # BeginExtend -- # # This procedure is typically invoked on shift-button-1 presses. It # begins the process of extending a selection in the hierarchy. Its # exact behavior depends on the selection mode currently in effect # for the hierarchy; # # Arguments: # w - The hierarchy widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. ;proc BeginExtend {w el} { if {[catch {_index $w $el} el]} return if {[string match multiple [_cget $w -selectmode]]} { Motion $w $el } } # BeginToggle -- # # This procedure is typically invoked on control-button-1 presses. It # begins the process of toggling a selection in the hierarchy. Its # exact behavior depends on the selection mode currently in effect # for the hierarchy; see the Motif documentation for details. # # Arguments: # w - The hierarchy widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. ;proc BeginToggle {w el} { global tkPriv if {[catch {_index $w $el} el]} return if {[string match multiple [_cget $w -selectmode]]} { _selection $w anchor $el if {[_selection $w includes $el]} { _selection $w clear $el } else { _selection $w set $el } set tkPriv(hierarchyPrev) $el } } # AutoScan -- # This procedure is invoked when the mouse leaves an entry window # with button 1 down. It scrolls the window up, down, left, or # right, depending on where the mouse left the window, and reschedules # itself as an "after" command so that the window continues to scroll until # the mouse moves back into the window or the mouse button is released. # # Arguments: # w - The hierarchy widget. ;proc AutoScan {w} { global tkPriv if {![winfo exists $w]} return set x $tkPriv(x) set y $tkPriv(y) if {$y>=[winfo height $w]} { $w yview scroll 1 units } elseif {$y<0} { $w yview scroll -1 units } elseif {$x>=[winfo width $w]} { $w xview scroll 2 units } elseif {$x<0} { $w xview scroll -2 units } else { return } #Motion $w [$w index @$x,$y] set tkPriv(afterId) [after 50 [namespace current]::AutoScan $w] } # SelectAll # # This procedure is invoked to handle the "select all" operation. # For single and browse mode, it just selects the root element. # Otherwise it selects everything in the widget. # # Arguments: # w - The hierarchy widget. ;proc SelectAll w { if {[regexp (browse|single) [_cget $w -selectmode]]} { _selection $w clear _selection $w set root } else { _selection $w set all } } #------------------------------------------------------------ # Default nodelook methods #------------------------------------------------------------ ;proc FileLook { w np isopen } { upvar \#0 [namespace current]::$w data set path [eval file join $np] set file [lindex $np end] set bmp {} if {[file readable $path]} { if {[file isdirectory $path]} { if {$isopen} { ## We know that kids will always be set by the time ## the isopen is set to 1 if {[string compare $data(:$np,kids) {}]} { set bmp ::Widget::Hierarchy::bmp:dir_minus } else { set bmp ::Widget::Hierarchy::bmp:dir } } else { set bmp ::Widget::Hierarchy::bmp:dir_plus } if 0 { ## NOTE: accurate, but very expensive if {[string compare [FileList $w $np] {}]} { set bmp [expr {$isopen ?\ {::Widget::Hierarchy::bmp:dir_minus} :\ {::Widget::Hierarchy::bmp:dir_plus}}] } else { set bmp ::Widget::Hierarchy::bmp:dir } } } set fg \#000000 } elseif {[string compare $data(-showparent) {}] && \ [string match $data(-showparent) $file]} { set fg \#0000FF set bmp ::Widget::Hierarchy::bmp:up } else { set fg \#a9a9a9 if {[file isdirectory $path]} {set bmp ::Widget::Hierarchy::bmp:dir} } return [list $file $data(-font) $bmp $fg] } ## FileList # ARGS: w hierarchy widget # np node path # Returns: directory listing ## ;proc FileList { w np } { set pwd [pwd] if {[catch "cd \[file join $np\]"]} { set list {} } else { global tcl_platform upvar \#0 [namespace current]::$w data set str * if {!$data(-showfiles)} { append str / } if {$data(-showall) && [string match unix $tcl_platform(platform)]} { ## NOTE: Use of non-core lremove if {[catch {lsort [concat [glob -nocomplain $str] \ [lremove [glob -nocomplain .$str] {. ..}]]} list]} { return {} } } else { ## The extra catch is necessary for unusual error conditions if {[catch {lsort [glob -nocomplain $str]} list]} { return {} } } set root $data(-root) if {[string compare {} $data(-showparent)] && \ [string match $root $np]} { if {![regexp {^(.:)?/+$} $root] && \ [string compare [file dir $root] $root]} { set list [linsert $list 0 $data(-showparent)] } } } cd $pwd return $list } ;proc FileActivate { w np isopen } { upvar \#0 [namespace current]::$w data set path [eval file join $np] if {[file isdirectory $path]} return if {[string compare $data(-showparent) {}] && \ [string match $data(-showparent) [lindex $np end]]} { $w configure -root [file dir $data(-root)] } } ;proc WidgetLook { W np isopen } { upvar \#0 [namespace current]::$W data if {$data(-showall)} { set w [lindex $np end] } else { set w [join $np {}] regsub {\.\.} $w {.} w } if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black} return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg] } ;proc WidgetList { W np } { upvar \#0 [namespace current]::$W data if {$data(-showall)} { set w [lindex $np end] } else { set w [join $np {}] regsub {\.\.} $w {.} w } set kids {} foreach i [lsort [winfo children $w]] { if {$data(-showall)} { lappend kids $i } else { lappend kids [file extension $i] } } return $kids } ;proc WidgetActivate { w np isopen } {} ;proc RegistryLook { W np isopen } { upvar \#0 [namespace current]::$W data if {$isopen} { ## We know that kids will always be set by the time ## the isopen is set to 1 if {[string compare $data(:$np,kids) {}]} { set bmp ::Widget::Hierarchy::bmp:dir_minus } else { set bmp ::Widget::Hierarchy::bmp:dir } } else { set bmp ::Widget::Hierarchy::bmp:dir_plus } return [list [lindex $np end] {} $bmp {}] } ;proc RegistryList { W np } { upvar \#0 [namespace current]::$W data set np [join [lrange $np 1 end] \\] #puts [info level 0]:$np if {[string match "" $np]} { set kids {HKEY_LOCAL_MACHINE HKEY_USERS HKEY_CLASSES_ROOT HKEY_CURRENT_USER HKEY_CURRENT_CONFIG} } else { set kids [lsort -dictionary [registry keys $np]] } return $kids } ;proc RegistryAct { w np isopen } {} ## BITMAPS ## image create bitmap ::Widget::Hierarchy::bmp:dir -data {#define folder_width 16 #define folder_height 12 static char folder_bits[] = { 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};} image create bitmap ::Widget::Hierarchy::bmp:dir_plus -data {#define folder_plus_width 16 #define folder_plus_height 12 static char folder_plus_bits[] = { 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40, 0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};} image create bitmap ::Widget::Hierarchy::bmp:dir_minus -data {#define folder_minus_width 16 #define folder_minus_height 12 static char folder_minus_bits[] = { 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};} image create bitmap ::Widget::Hierarchy::bmp:up -data {#define up.xbm_width 16 #define up.xbm_height 12 static unsigned char up.xbm_bits[] = { 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00, 0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};} image create bitmap ::Widget::Hierarchy::bmp:text -data {#define text_width 15 #define text_height 14 static char text_bits[] = { 0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1, 0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};} }; # end namespace ::Widget::Hierarchy return |
Added library/megalist.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 | ## ## megalist.tcl ## ## Copyright 1997-8 Jeffrey Hobbs ## package require Widget 2.0 package provide Megalist 1.0 ##------------------------------------------------------------------------ ## PROCEDURE ## megalist ## ## ARGUMENTS && DESCRIPTION ## ## megalist <window pathname> <options> ## Implements a megalist which displays a sorted and filtered ## list of lists. ## ## OPTIONS ## ## -sortby item DEFAULT: none ## Specifies which item to sort on. ## ## -sort TCL_BOOLEAN DEFAULT: 1 ## If true the sort buttons appear and the lists are sorted ## by the item specified by -sortby. If false the sort buttons ## disappear and the lists are not sorted. ## ## ## -showfilters TCL_BOOLEAN DEFAULT: 0 ## ## -shownames TCL_BOOLEAN DEFAULT: 1 ## ## METHODS ## These are the methods that the megalist object recognizes. ## (ie - megalist .m ; .m <method> <args>) ## Any unique substring is acceptable ## ## load list ## Each element in the list is displayed as a row in the widget. ## Each element in the row is assigned to an item starting from the left. ## If there are less item elements than items blanks are assigned. ## If there are more item elements than items they are ignored. ## ## add item ?args? ## Adds a display for the new item in the list. ## ## delete item ?item ...? ## Deletes the item(s) and removes the display(s). ## ## itemconfigure item ?option? ?value option value ...? ## Query or modify the configuration options of the item. ## ## itemcget item option ## Returns the current value of the item's configuration option. ## ## names ?pattern? ## Returns the item names that match pattern. Defaults to *. ## ## BINDINGS ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ## ##------------------------------------------------------------------------ ## ## # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc Megalist args {} proc megalist args {} widget create Megalist -type frame -base frame -components { {frame hold hold {-height 200 -width 200 -bg pink}} {scrollbar yscrollbar sy {-bd 1 -takefocus 0 -highlightthickness 0 \ -orient v -command [namespace code [list lbset $w yview]]}} } -options { {-sortby sortby SortBy {}} {-sortcmd sortcmd SortCmd ::Widget::Megalist::sort} {-shownames shownames ShowNames 1} {-showfilters showfilters ShowFilters 0} {-style style Style listbox} {-font font Font fixed} {-selectproc selectProc SelectProc {}} {-dataproc dataProc DataProc {}} {-filtercmd filtercmd FilterCmd ::Widget::Megalist::filter} } namespace eval ::Widget::Megalist {; ;proc construct w { upvar \#0 [namespace current]::$w data ## Private variables array set data [list \ order {} \ lists {} \ count 0 \ height 0 \ reload {} \ data {} \ ] grid $data(hold) $data(yscrollbar) -sticky news grid config $data(yscrollbar) -sticky ns grid columnconfig $w 0 -weight 1 grid rowconfig $w 0 -weight 1 } ;proc init w { } ;proc destruct w { upvar \#0 [namespace current]::$w data catch {pane forget $data(hold)} } ;proc configure {w args} { upvar \#0 [namespace current]::$w data set truth {^(1|yes|true|on)$} set reload 0 foreach {key val} $args { switch -- $key { -sortby { if {[llength $val]>1} { return -code error "multiple sort fields not supported" } if {![string compare $val $data(-sortby)]} continue foreach v $val { if {[lsearch $data(order) $v] == -1} { return -code error "unrecognized field \"$name\"" } } if {[info exists set($v)]} { return -code error "field \"$name\" set twice" } set set($v) 0 set reload 1 } -showfilters { set val [regexp -nocase $truth $val] if {$data(-showfilters) == $val} continue if $data(-showfilters) { foreach name $data(order) { pack forget $data(hold).$name.e } } else { foreach name $data(order) { pack $data(hold).$name.e -fill x \ -before $data(hold).$name.c } } } -shownames { set val [regexp -nocase $truth $val] if { $data(-shownames) == $val } {continue} if $data(-shownames) { foreach name $data(order) { pack forget $data(hold).$name.b } } else { set x c if [winfo exists $data(hold).$name.e] { set x e } foreach name $data(order) { pack $data(hold).$name.b -fill x \ -before $data(hold).$name.$x } } } } set data($key) $val } if {$reload} {_refresh $w} } ;proc _load {w args} { upvar \#0 [namespace current]::$w data if {[string match {} $data(order)]} { return -code error "no fields in megalist" } set data(data) $args catch {$data(err) load $args} result _refresh $w return $result } #refresh or reload? ;proc _refresh {w} { upvar \#0 [namespace current]::$w data after cancel $data(reload) set data(reload) [after idle load $w] return } ;proc load {w} { upvar \#0 [namespace current]::$w data if {[string match {} $data(data)]} return foreach name $data(order) { set box $data(hold).$name.c $box delete 0 end eval $box insert end [$data(err) fldmsg $name] } } ;proc setsort {w b name} { upvar \#0 [namespace current]::$w data array set config $data(I:$name) if {[string compare $name $data(-sortby)]} { set data(-sortby) $name set config(-order) increasing } else { if {[string compare increasing $config(-order)]} { set config(-order) increasing } else { set config(-order) decreasing } } set data(I:$name) [array get config] _refresh $w } ;proc _add {w name args} { upvar \#0 [namespace current]::$w data if {[info exists data(I:$name)]} { # Ensure name doesn't already exist return -code error "field \"$name\" already exists" } if {[regexp {(^[\.A-Z]|[ \.])} $name]} { return -code error "invalid item name \"$name\": it cannot begin\ with a capital letter, or contain spaces or \".\"" } if {[llength $args]&1} { return -code error "wrong \# of args to add method \"$args\"" } get_opts2 config $args { -filtertype match -match * -sort ascii } set data(I:$name) [array get config] set data(IF:$name) $config(-match) lappend data(order) $name if {[catch {additem $w} result]} { set data(order) [lreplace $data(order) end end] unset data(I:$name) data(IF:$name) return -code error $result } add $w $name return $name } ;proc additem {w args} { upvar \#0 [namespace current]::$w data foreach name $data(order) { array set config $data(I:$name) set field [list $name -sort $config(-sort)] lappend fields $field unset config } } ;proc add {w name} { upvar \#0 [namespace current]::$w data array set config $data(I:$name) set f [frame $data(hold).$name] button $f.b -text $name -bd 1 -highlightthickness 0 \ -takefocus 0 -padx 6 -pady 2 \ -command [namespace code [list setsort $w $f.b $name]] entry $f.e -textvariable ${w}(IF:$name) -bd 1 \ -highlightthickness 0 -takefocus 0 -justify center set box [listbox $f.c -highlightthickness 0 -bd 0 -takefocus 0 \ -yscrollcommand [namespace code [list scroll $w]] -exportsel 0] $f.c xview moveto 0 if $data(-shownames) { pack $f.b -fill x} if $data(-showfilters) {pack $f.e -fill x} pack $f.c -fill both -expand 1 pane $f -parent $data(hold) -handlelook {-bd 1 -width 2} bind $f.c <ButtonRelease-1> [namespace code [list select $w $f.c]] bind $f.e <Return> [namespace code [list _refresh $w]] set $data(IF:$name) $config(-match) } ;proc select {w p} { upvar \#0 [namespace current]::$w data if [string match {} [set idx [$p curselection]]] {return} foreach i $data(order) { $w.hold.$i.c selection clear 0 end $w.hold.$i.c selection set $idx } if {[string compare {} $data(-selectproc)]} { foreach i $data(order) { lappend select [$w.hold.$i.c get $idx] } ## No $select here! if {[string compare {} $select]} { eval $data(-selectproc) $w $select } } } ;proc _delete {w args} { upvar \#0 [namespace current]::$w data foreach name $args { ## Don't complain about unknown items when deleting set wid $data(hold).$name catch { unset data(I:$name) data(IF:$name) pane forget $data(hold) $wid destroy $wid } if {[set i [lsearch -exact $data(order) $name]] != -1} { set data(order) [lreplace $data(order) $i $i] } if {[set i [lsearch -exact $data(-sortby) $name]] != -1} { set data(-sortby) [lreplace $data(-sortby) $i $i] } } } ## _itemconfigure ## configure a progressbar constituent item ## ;proc _itemconfigure {w name args} { upvar \#0 [namespace current]::$w data if {![info exists data(I:$name)]} { return -code error "unknown field \"$name\"" } array set config $data(I:$name) if {[catch {$data(err) field $name $args} result]} { $data(err) field $name [array get config] return -code error $result } if {[llength $args] > 1} { array set config $args set data(IF:$name) $config(match) set data(I:$name) $args _refresh $w } return $result } ## _itemcget ## Returns a single item option ## ;proc _itemcget {w name opt} { upvar \#0 [namespace current]::$w data if {![info exists data(I:$name)]} { return -code error "unknown item \"$name\"" } array set config $data(I:$name) ## Ensure that we are getting a -'ed value if {![info exists config(-[string range $opt 1 end])]} { return -code error "unknown option \"$opt\"" } return $config($opt) } ## _names ## Return a list of item names ## ;proc _names {w {pattern *}} { upvar \#0 [namespace current]::$w data set names {} foreach name $data(order) { if {[string match $pattern $name]} { lappend names $name } } return $names } ;proc lbset {w args} { upvar \#0 [namespace current]::$w data foreach name $data(order) { eval [list $data(hold).$name.c] $args } } ;proc scroll {w args} { upvar \#0 [namespace current]::$w data eval $data(yscrollbar) set $args lbset $w yview moveto [lindex $args 0] } }; # end namespace ::Widget::Megalist |
Added library/pane.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | ## Paned Window Procs inspired by code by Stephen Uhler @ Sun. ## Thanks to John Ellson ([email protected]) for bug reports & code ideas. ## ## Copyright 1996-1997 Jeffrey Hobbs, [email protected] ## package provide Pane 1.0 ##------------------------------------------------------------------ ## PROCEDURE ## pane ## ## DESCRIPTION ## paned window management function ## ## METHODS ## ## pane configure <widget> ?<widget> ...? ?<option> <value>? ## pane <widget> ?<widget> ...? ?<option> <value>? ## Sets up the management of the named widgets as paned windows. ## ## OPTIONS ## -dynamic Whether to dynamically resize or to resize only ## when the user lets go of the handle ## -orient Orientation of window to determing tiling. ## Can be either horizontal (default) or vertical. ## -parent A master widget to use for the slaves. ## Defaults to the parent of the first widget. ## -handlelook Options to pass to the handle during 'frame' creation. ## -handleplace Options to pass to the handle during 'place'ment. ## Make sure you know what you're doing. ## ## pane forget <master> ?<slave> ...? ## If called without a slave name, it forgets all slaves and removes ## all handles, otherwise just removes the named slave(s) and redraws. ## ## pane info <slave> ## Returns the value of [place info <slave>]. ## ## pane slaves <master> ## Returns the slaves currently managed by <master>. ## ## pane master <slave> ## Returns the master currently managing <slave>. ## ## BEHAVIORAL NOTES ## pane is a limited interface to paned window management. Error ## catching is minimal. When you add more widgets to an already managed ## parent, all the fractions are recalculated. Handles have the name ## $parent.__h#, and will be created/destroyed automagically. You must ## use 'pane forget $parent' to clean up what 'pane' creates, otherwise ## critical state info about the parent pane will not be deleted. This ## could support -before/after without too much effort if the desire ## was there. Because this uses 'place', you have to take the same care ## to size the parent yourself. ## ## VERSION 1.0 ## ## EXAMPLES AT END OF FILE ## ## FIX: should be able to set original ratio proc pane {opt args} { global PANE switch -glob -- $opt { c* { eval pane_config $args } f* { set p [lindex $args 0] if {[info exists PANE($p,w)]} { if {[llength $args]==1} { foreach w $PANE($p,w) { catch {place forget $w} } foreach w [array names PANE $p,*] { unset PANE($w) } if {![catch {winfo children $p} kids]} { foreach w $kids { if {[string match *.__h* $w]} { destroy $w } } } } else { foreach w [lrange $args 1 end] { place forget $w set i [lsearch -exact $PANE($p,w) $w] set PANE($p,w) [lreplace $PANE($p,w) $i $i] } if [llength $PANE($p,w)] { eval pane_config $PANE($p,w) } else { pane forget $p } } } else { } } i* { return [place info $args] } s* { if {[info exists PANE($args,w)]} { return $PANE($args,w) } { return {} } } m* { foreach w [array names PANE *,w] { if {[lsearch $PANE($w) $args] != -1} { regexp {([^,]*),w} $w . res return $res } } return -code error \ "no master found. perhaps $args is not a pane slave?" } default { eval pane_config [list $opt] $args } } } ## ## PRIVATE FUNCTIONS ## ## I don't advise playing with these because they are slapped together ## and delicate. I don't recommend calling them directly either. ## ;proc pane_config args { global PANE array set opt {orn none par {} dyn 0 hpl {} hlk {}} set wids {} for {set i 0;set num [llength $args];set cargs {}} {$i<$num} {incr i} { set arg [lindex $args $i] if [winfo exists $arg] { lappend wids $arg; continue } set val [lindex $args [incr i]] switch -glob -- $arg { -d* { set opt(dyn) [regexp -nocase {^(1|yes|true|on)$} $val] } -o* { set opt(orn) $val } -p* { set opt(par) $val } -handlep* { set opt(hpl) $val } -handlel* { set opt(hlk) $val } default { return -code error "unknown option \"$arg\"" } } } if {[string match {} $wids]} { return -code error "no widgets specified to configure" } if {[string compare {} $opt(par)]} { set p $opt(par) } else { set p [winfo parent [lindex $wids 0]] } if {[string match none $opt(orn)]} { if {![info exists PANE($p,o)]} { set PANE($p,o) h } } else { set PANE($p,o) $opt(orn) } if {[string match h* $PANE($p,o)]} { set owh height; set wh width; set xy x; set hv h } else { set owh width; set wh height; set xy y; set hv v } if ![info exists PANE($p,w)] { set PANE($p,w) {} } foreach w [winfo children $p] { if {[string match *.__h* $w]} { destroy $w } } foreach w $wids { set i [lsearch -exact $PANE($p,w) $w] if {$i<0} { lappend PANE($p,w) $w } } set ll [llength $PANE($p,w)] set frac [expr {1.0/$ll}] set pos 0.0 array set hndconf $opt(hlk) if {![info exists hndconf(-$wh)]} { set hndconf(-$wh) 4 } foreach w $PANE($p,w) { place forget $w place $w -in $p -rel$owh 1 -rel$xy $pos -$wh -$hndconf(-$wh) \ -rel$wh $frac -anchor nw raise $w set pos [expr {$pos+$frac}] } place $w -$wh 0 while {[incr ll -1]} { set h [eval frame [list $p.__h$ll] -bd 2 -relief sunken \ -cursor sb_${hv}_double_arrow [array get hndconf]] eval place [list $h] -rel$owh 1 -rel$xy [expr {$frac*$ll}] \ -$xy -$hndconf(-$wh) -anchor nw $opt(hpl) raise $h bind $h <ButtonPress-1> "pane_constrain $p $h \ [lindex $PANE($p,w) [expr {$ll-1}]] [lindex $PANE($p,w) $ll] \ $wh $xy $opt(dyn)" } } ;proc pane_constrain {p h w0 w1 wh xy d} { global PANE regexp -- "\-rel$xy (\[^ \]+)" [place info $w0] junk t0 regexp -- "\-rel$xy (\[^ \]+).*\-rel$wh (\[^ \]+)" \ [place info $w1] junk t1 t2 set offset [expr {($t1+$t2-$t0)/10.0}] array set PANE [list XY [winfo root$xy $p] WH [winfo $wh $p].0 \ W0 $w0 W1 $w1 XY0 $t0 XY1 [expr {$t1+$t2}] \ C0 [expr {$t0+$offset}] C1 [expr {$t1+$t2-$offset}]] bind $h <B1-Motion> "pane_motion %[string toup $xy] $p $h $wh $xy $d" if !$d { bind $h <ButtonRelease-1> \ "pane_motion %[string toup $xy] $p $h $wh $xy 1" } } ;proc pane_motion {X p h wh xy d} { global PANE set f [expr {($X-$PANE(XY))/$PANE(WH)}] if {$f<$PANE(C0)} { set f $PANE(C0) } if {$f>$PANE(C1)} { set f $PANE(C1) } if $d { place $PANE(W0) -rel$wh [expr {$f-$PANE(XY0)}] place $h -rel$xy $f place $PANE(W1) -rel$wh [expr {$PANE(XY1)-$f}] -rel$xy $f } else { place $h -rel$xy $f } } ## ## EXAMPLES ## ## These auto-generate for the plugin. Remove these for regular use. ## if {[info exists embed_args]} { ## Hey, super-pane the one toplevel we get! pane [frame .0] [frame .1] ## Use the line below for a good non-plugin example #toplevel .0; toplevel .1 pane [listbox .0.0] [listbox .0.1] -dynamic 1 pane [frame .1.0] [frame .1.1] -dyn 1 pane [listbox .1.0.0] [listbox .1.0.1] [listbox .1.0.2] -orient vertical pack [label .1.1.0 -text "Text widget:"] -fill x pack [text .1.1.1] -fill both -expand 1 set i [info procs] foreach w {.0.0 .0.1 .1.0.0 .1.0.1 .1.0.2 .1.1.1} { eval $w insert end $i } } ## ## END EXAMPLES ## ## EOF |
Added library/pkgIndex.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Tcl package index file, version 1.0 package ifneeded AllWidgets 1.0 { package require Widget package require BalloonHelp package require Calculator package require Combobox package require Console package require Hierarchy package require Megalist package require Pane package require Progressbar package require Tabnotebook package require Ventry package provide AllWidgets 1.0 } package ifneeded BalloonHelp 2.0 [list tclPkgSetup $dir BalloonHelp 2.0 { {balloonhelp.tcl source { balloonhelp } } }] ## Not ready yet package ifneeded Calculator 1.0 [list tclPkgSetup $dir Calculator 1.0 { {calculator.tcl source { Calculator }}}] package ifneeded Combobox 2.0 [list tclPkgSetup $dir Combobox 2.0 { {combobox.tcl source { Combobox combobox } } }] package ifneeded Console 2.0 [list tclPkgSetup $dir Console 2.0 { {console.tcl source { Console ConsoleDialog console consoledialog } } }] package ifneeded Hierarchy 2.0 [list tclPkgSetup $dir Hierarchy 2.0 { {hierarchy.tcl source { Hierarchy hierarchy hierarchy_dir hierarchy_widget } } }] package ifneeded Megalist 1.0 [list tclPkgSetup $dir Megalist 1.0 { {megalist.tcl source { megalist } } }] package ifneeded Pane 1.0 [list tclPkgSetup $dir Pane 1.0 { {pane.tcl source { pane } } }] package ifneeded Progressbar 2.0 [list tclPkgSetup $dir Progressbar 2.0 { {progressbar.tcl source { Progressbar progressbar } } }] package ifneeded Tabnotebook 2.0 [list tclPkgSetup $dir Tabnotebook 2.0 { {tabnotebook.tcl source { Tabnotebook tabnotebook } } }] package ifneeded Ventry 2.0 [list tclPkgSetup $dir Ventry 2.0 { {ventry.tcl source { Ventry ventry } } }] package ifneeded Widget 2.0 [list tclPkgSetup $dir Widget 2.0 { {widget.tcl source { widget scrolledtext ScrolledText } } }] package ifneeded ::Utility 1.0 [subst { source [file join $dir util.tcl] }] # get_opts get_opts2 randrng best_match grep # lremove lrandomize lunique luniqueo # line_append echo alias which ls dir validate fit_format package ifneeded ::Utility::dump 1.0 [subst { source [file join $dir util-dump.tcl] }] # dump package ifneeded ::Utility::string 1.0 [subst { source [file join $dir util-string.tcl] }] # string_reverse obfuscate untabify tabify wrap_lines package ifneeded ::Utility::number 1.0 [subst { source [file join $dir util-number.tcl] }] # get_square_size roman2dec bin2hex hex2bin package ifneeded ::Utility::tk 1.0 [subst { source [file join $dir util-tk.tcl] }] # warn place_window canvas_center canvas_see package ifneeded ::Utility::expand 1.0 [subst { source [file join $dir util-expand.tcl] }] # expand package ifneeded ::Utility::tools 1.0 [subst { source [file join $dir util-tools.tcl] }] # expand |
Added library/progressbar.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | ## ## Copyright 1996-1997 Jeffrey Hobbs, [email protected] ## Some Enhancements done by Steve Ball ## package require Widget 2.0 package provide Progressbar 2.0 ##------------------------------------------------------------------------ ## PROCEDURE ## progressbar ## ## DESCRIPTION ## Implements a Progressbar mega-widget ## ## ARGUMENTS ## progressbar <window pathname> <options> ## ## OPTIONS ## (Any canvas widget option may be used in addition to these) ## ## -indicatorcolor DEFAULT: #5ae6fe ## The color of the progressbar. Must be in #rgb format. ## This is also the default item start foreground color. ## ## -itembackground DEFAULT: {} ## Default item background color. {} means transparent. ## ## -itemfgfinished DEFAULT: #00ff00 (green) ## Default item finished foreground color. Must be in #rgb format. ## ## -itemtype DEFAULT: document ## Default item type (currently 'document' and 'image' are supported). ## ## -labelanchor anchor DEFAULT: c ## Anchor for the label. Reasonable values are c, w and e. ## ## -labeltext string DEFAULT: {} ## Text for the label ## ## -labelwidth # DEFAULT: 0 (self-sizing) ## Width for the label ## ## -maxvalue # DEFAULT: 0 (percentage-based) ## This represents what the representative max value of the progress ## bar is. If it is 0, the progress bar interprets the -value option ## like a percentage (with an implicit 100 value for -maxvalue), ## otherwise it is representative of what -value would have to reach ## for the progress to be at 100%. ## ## -orientation horizontal|vertical DEFAULT: horizontal ## Orientation of the progressbar ## ## -showvalue TCL_BOOLEAN DEFAULT: 1 ## Whether or not to show the exact value beside the bar (it is ## displayed as a percentage of the possible max value). ## ## -showerror TCL_BOOLEAN DEFAULT: 1 ## Whether to raise an error in the trace on the -variable if the ## appropriate range is exceeded. ## ## -value # DEFAULT: 0 ## The value of the progress bar. This will be used to calculate the ## overall progress percentage in conjunction with the -maxvalue option. ## ## -variable varname DEFAULT: {} ## A variable from which to get the value for the bar. This variable ## will have a trace set upon it that forces a postive value. It cannot ## be unset until the widget is destroyed or you change this option. ## ## METHODS ## These are the methods that this megawidget recognizes. Aside from ## those listed here, it accepts what is valid for canvas widgets. ## ## create ?item? ?-option value ...? ## Start displaying the progress of an item. "item" is the ## name to associate with the item. If no name is supplied, a unique ## name is generated. If an item of the same name already exists, then ## a new unique name is generated. Returns the name of the created item. ## ## delete item ## Remove the given item from the list of items being displayed. ## Total progress is updated appropriately. ## ## itemconfigure item ?-option value? ## Sets option(s) for an item. ## ## VALID ITEM OPTIONS ## ## -background color Background color of icon associated with item. ## -fgstart #rgb Initial foreground color of item's icon. ## -fgfinished #rgb Final foreground color of item's icon. ## The progressbar changes the shade of the icon ## from the initial to the final color in ## conjunction with the %age of maxvalue. ## -maxvalue # max value that represents 100% of possible value ## -type type item type (document and image currently supported) ## This can only be set at creation. ## -value # current progress toward full value of maxvalue ## ## itemcget item -option ## Returns the current value of the option for the given item ## ## names ?pattern? ## Returns the names of the progressbar's constituent items. ## An optional pattern can limit the return result. ## ## recalculate ## Recalculates the value and maxvalue of the progressbar based ## on the values of the consituent items, if any. This is only ## necessary when changing from using the progressbar without items ## to using it with items. ## ## subwidget widget ## Returns the true widget path of the specified widget. Valid ## widgets are label, canvas. ## ## BINDINGS ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ## EXAMPLE USAGE: ## ## pack [progressbar .p -labeltext "Usage:" -variable usage] -fill x -exp 1 ## for {set i 0} {$i <= 10} {incr i} { set usage ${i}0; update; after 1000 } ## ## ##------------------------------------------------------------------------ # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc Progressbar args {} proc progressbar args {} widget create Progressbar -type frame -base canvas -components { label {base canvas canvas {-highlightthickness 0 \ -bd 1 -relief ridge -width 100 -height 25}} } -options { {-bd -borderwidth} {-borderwidth borderWidth BorderWidth 0} {-font ALIAS label -font} {-fg -foreground} {-foreground ALIAS label -foreground} {-indicatorcolor indicatorColor Color #5ae6fe} {-indicatorcolour -indicatorcolor} {-itembackground itemBackground Background {}} {-itemfgfinished itemForegroundFinished Foreground #00ff00} {-itemtype itemType ItemType document} {-labelanchor labelAnchor Anchor c} {-labeltext labelText Text {}} {-labelwidth labelWidth Width 0} {-maxvalue maxValue Value 0} {-orientation orientation Orientation horizontal} {-relief relief Relief flat} {-showvalue showValue ShowValue 1} {-showerror showError ShowError 1} {-value value Value 0} {-variable variable Variable {}} } namespace eval ::Widget::Progressbar {; ;proc construct {w} { upvar \#0 [namespace current]::$w data ## Private variables array set data { counter 0 } set data(items) $data(class)${w}ITEMS grid $data(label) $data(canvas) -in $w -sticky ns grid configure $data(canvas) -sticky news grid columnconfig $w 1 -weight 1 grid rowconfig $w 0 -weight 1 grid remove $data(label) bind $data(canvas) <Configure> [namespace code [list resize $w %w %h]] } ;proc init {w} { upvar \#0 [namespace current]::$w data $data(basecmd) create rect -1 0 0 25 -fill $data(-indicatorcolor) \ -tags bar -outline {} $data(basecmd) create text 25 12 -fill $data(-foreground) \ -tags text -anchor c $data(basecmd) xview moveto 0 $data(basecmd) yview moveto 0 } ;proc configure { w args } { upvar \#0 [namespace current]::$w data set truth {^(1|yes|true|on)$} set resize 0 set force 0 foreach {key val} $args { switch -- $key { -borderwidth - -relief { .$w configure $key $val } -font { $data(label) configure -font $val $data(basecmd) itemconfigure text -font $val } -foreground { $data(label) configure -foreground $val $data(basecmd) itemconfigure text -fill $val } -indicatorcolor { $data(basecmd) itemconfigure bar -fill $val } -labelanchor { $data(label) configure -anchor $val } -labeltext { $data(label) configure -text $val if {[string compare {} $val]} { grid $data(label) } else { grid remove $data(label) } } -labelwidth { $data(label) configure -width $val } -maxvalue { if {![regexp {^[0-9]+$} $val] || $val<0} { return -code error "$key must be a positive integer" } set force 1 } -orientation { if {[string match h* $val]} { set val horizontal } elseif {[string match v* $val]} { set val vertical } else { return -code error \ "orientation must be horizontal or vertical" } if {[string compare $data($key) $val]} { set W [$data(basecmd) cget -width] set H [$data(basecmd) cget -height] $data(basecmd) configure -height $W -width $H set resize 1 } } -showvalue { set val [regexp -nocase $truth $val] set resize 1 } -showerror { set val [regexp -nocase $truth $val] } -value { if {[catch {barset $w $val} err] && \ $data(-showerror)} { return -code error $err } if {$resize} { set resize 0 } if {$force} { set force 0 } continue } -variable { if {![string compare $val $data(-variable)]} return if {[string compare {} $data(-variable)]} { uplevel \#0 [list trace vdelete $data(-variable) wu \ [namespace code [list bartrace $w]]] set data(-variable) {} } if {[string compare {} $val]} { set data(-variable) $val upvar \#0 $val var if {![info exists var] || \ [catch {barset $w $var} err]} { set var $data(-value) } uplevel \#0 [list trace var $val wu \ [namespace code [list bartrace $w]]] } ## avoid the set data($key) continue } } set data($key) $val } if {$force || ($resize && [winfo ismapped $data(canvas)])} { resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] } } ;proc destruct w { upvar \#0 [namespace current]::$w data catch {configure $w -variable {}} } ;proc bartrace {w name el op} { upvar \#0 [namespace current]::$w data upvar \#0 $data(-variable) var if {[string match u $op]} { set var $data(-value) uplevel \#0 [list trace var $data(-variable) wu \ [namespace code [list bartrace $w]]] } elseif {[catch {barset $w $var} err]} { set var $data(-value) if $data(-showerror) { return -code error $err } } } ;proc resize {w W H} { upvar \#0 [namespace current]::$w data ## Assume a maxvalue of 100 if maxvalue is 0 (works like %age) if {$data(-maxvalue)} { set pcnt [expr {$data(-value)/double($data(-maxvalue))}] } else { set pcnt [expr {$data(-value)/100.0}] } if {[string match h* $data(-orientation)]} { $data(basecmd) coords bar -1 0 [expr {$pcnt*$W}] $H } else { ## Vertical orientation needs testing ## it is upside down $data(basecmd) coords bar -1 $H $W [expr {$pcnt*$H}] } if $data(-showvalue) { $data(basecmd) coords text [expr {$W/2}] [expr {$H/2-2}] $data(basecmd) itemconfigure text -text \ [format {%5.1f%%} [expr {$pcnt*100.0}]] } else { $data(basecmd) coords text $W $H } } ;proc barset {w val} { upvar \#0 [namespace current]::$w data if {![regexp {^[0-9]+$} $val] || $val<0} { return -code error "value must be an integer greater than 0" } if {[string comp {} $data(-variable)]} { upvar \#0 $data(-variable) var if {[catch {set var $val} err]} { return -code error $err } } set data(-value) $val resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] } # Manage progress items. These may be documents or images. # (There needs to be an extensible system to allow other types, eg. Tclets) # Each item may have a max value and a current value. # The total download progress is calculated from the sums of item sizes. ;proc _create {w args} { set namesp [namespace current] upvar \#0 ${namesp}::$w data set cnt [incr data(counter)] if {[string match -* [lindex $args 0]]} { # Invent a name set item progress$cnt } else { set item [lindex $args 0] set args [lrange $args 1 end] if {[info exists data(I:$item)]} { # Ensure name doesn't already exist return -code error "item \"$item\" already exists" } } array set config [list \ -background $data(-itembackground) \ -fgstart $data(-indicatorcolor) \ -fgfinished $data(-itemfgfinished) \ -maxvalue 100 \ -type $data(-itemtype) \ -value 0 \ ] array set configargs $args if {[info exists configargs(-type)]} { if {[string match {} \ [info commands ${namesp}::icon_$configargs(-type)]]} { return -code error "invalid item type $configargs(-type)" } set config(-type) $configargs(-type) unset configargs(-type) } incr data(-maxvalue) $config(-maxvalue) incr data(-value) $config(-value) # Add to display set config(image) [image create bitmap $w:$item \ -data [${namesp}::icon_$config(-type) cget -data] \ -foreground $config(-fgstart) \ -background $config(-background)] set config(w) [label $w.item$cnt -image $config(image)] foreach {ncols nrows} [grid size $w] break if {[string match h* $data(-orientation)]} { grid $config(w) -row 0 -column $ncols } else { grid $config(w) -row $nrows -column 0 } set data(I:$item) [array get config] if {[string compare {} $args]} { eval _itemconfigure [list $w] [list $item] [array get configargs] } else { barset $w $data(-value) } return $item } # Turns #rgb into 3 elem list of decimal vals. ;proc parse_color c { set c [string tolower $c] if {[regexp {^\#([0-9a-f])([0-9a-f])([0-9a-f])$} $c x r g b]} { # appending "0" right-shifts 4 bits scan "${r}0 ${g}0 ${b}0" "%x %x %x" r g b } else { if {![regexp {^\#([0-9a-f]+)$} $c junk hex] || \ [set len [string length $hex]]>12 || $len%3 != 0} { return -code error "bad color value \"$c\"" } set len [expr {$len/3}] scan $hex "%${len}x%${len}x%${len}x" r g b } return [list $r $g $b] } ## Returns a shade between two colors based on the frac (0.0-1.0) ;proc shade {orig dest frac} { if {$frac >= 1.0} { return $dest } elseif {$frac <= 0.0} { return $orig } foreach {origR origG origB} [parse_color $orig] \ {destR destG destB} [parse_color $dest] { set shade [format "\#%02x%02x%02x" \ [expr {int($origR+double($destR-$origR)*$frac)}] \ [expr {int($origG+double($destG-$origG)*$frac)}] \ [expr {int($origB+double($destB-$origB)*$frac)}]] return $shade } } ;proc _delete {w args} { upvar \#0 [namespace current]::$w data foreach item $args { ## Don't complain about unknown items when deleting if {![info exists data(I:$item)]} continue array set config $data(I:$item) incr data(-value) -$config(-value) incr data(-maxvalue) -$config(-maxvalue) if {$data(-value) < 0} { set data(-value) 0 } if {$data(-maxvalue) < 0} { set data(-maxvalue) 0 } destroy $config(w) image delete $config(image) unset data(I:$item) } barset $w $data(-value) } ## _itemconfigure ## configure a progressar constituent item ## ;proc _itemconfigure {w item args} { upvar \#0 [namespace current]::$w data if {![info exists data(I:$item)]} { return -code error "unknown item \"$item\"" } array set config $data(I:$item) if {[string match {} $args]} { return [array get config -*] } set valChanged 0 foreach {key val} $args { if {[string match {} [set arg [array names config $key]]]} { set arg [array names config ${key}*] } set num [llength $arg] if {$num==0} { return -code error "unknown option \"$key\", must be:\ [join [array names config -*] {, }]" } elseif {$num>1} { return -code error "ambiguous option \"$args\",\ must be one of: [join $arg {, }]" } else { set key $arg } switch -- $key { -maxvalue { if {![regexp {^[0-9]+$} $val] || $val<=0} { return -code error "$key must be an integer greater than 0" } incr data(-maxvalue) [expr {$val-$config(-maxvalue)}] if {$data(-maxvalue) < 0} { set data(-maxvalue) 0 } set valChanged 1 } -value { if {![regexp {^[0-9]+$} $val] || $val<0} { return -code error "$key must be a postive integer" } incr data(-value) [expr {$val-$config(-value)}] if {$data(-value) < 0} { set data(-value) 0 } set valChanged 1 } -type { ## Should we allow this to be changed? return -code error "-type cannot be changed after creation" } -fgstart { if {![regexp {^\#([0-9a-f]+)$} $val]} { return -code error "color value must be in \#rgb format" } } -fgfinished { if {![regexp {^\#([0-9a-f]+)$} $val]} { return -code error "color value must be in \#rgb format" } } } set config($key) $val } set data(I:$item) [array get config] if {$config(-maxvalue)} { $config(image) configure -background $config(-background) \ -foreground [shade $config(-fgstart) $config(-fgfinished) \ [expr {double($config(-value))/$config(-maxvalue)}]] } if {$valChanged} { barset $w $data(-value) } } ## _itemcget ## Returns a single item option ## ;proc _itemcget {w item opt} { upvar \#0 [namespace current]::$w data if {![info exists data(I:$item)]} { return -code error "unknown item \"$item\"" } array set config $data(I:$item) ## Ensure that we are getting a -'ed value if {![info exists config(-[string range $opt 1 end])]} { return -code error "unknown option \"$opt\"" } return $config($opt) } ## _names ## Return a list of item names ## ;proc _names {w {pattern *}} { upvar \#0 [namespace current]::$w data set items {} foreach name [array names data I:$pattern] { lappend items [string range $name 2 end] } return $items } ## _recalculate ## recalculates the percentage based purely on the constituent items ## If there are no items, it just ensures that -(max)value is >= 0 ## ;proc _recalculate {w} { upvar \#0 [namespace current]::$w data set items [array names data I:*] if {[string compare {} $items]} { set data(-maxvalue) 0 set data(-value) 0 foreach item $items { array set config $data($item) if {$config(-value) < 0} {set config(-value) 0} if {$config(-maxvalue) < 0} {set config(-maxvalue) 0} incr data(-value) $config(-value) incr data(-maxvalue) $config(-maxvalue) set data($item) [array get config] } } else { if {$data(-value) < 0} {set data(-value) 0} if {$data(-maxvalue) < 0} {set data(-maxvalue) 0} } barset $w $data(-value) return } image create bitmap [namespace current]::icon_document -data {#define document_width 20 #define document_height 23 static char document_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x1f, 0x00, 0x04, 0x30, 0x00, 0x04, 0x50, 0x00, 0x04, 0x90, 0x00, 0x04, 0x10, 0x01, 0x04, 0xf0, 0x03, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0xfc, 0xff, 0x03}; } image create bitmap [namespace current]::icon_image -data {#define image_width 20 #define image_height 23 static char image_bits[] = { 0xe0, 0xff, 0xff, 0x20, 0xe0, 0xff, 0xe0, 0xff, 0xff, 0x30, 0xff, 0xff, 0xe8, 0xf8, 0xff, 0xdf, 0xf7, 0xff, 0xbb, 0xff, 0xff, 0x7b, 0xff, 0xff, 0xfb, 0xfe, 0xff, 0xfb, 0xfd, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f, 0xff, 0xcf, 0x1f, 0xfc, 0x03, 0x0e, 0xf8, 0x20, 0x70, 0xf0, 0x18, 0x80, 0xf1, 0x07, 0x00, 0xf0, 0x00, 0x1e, 0xf0, 0xf8, 0x01, 0xf0, 0x00, 0x00, 0xf0, 0xc0, 0x7f, 0xf3, 0x00, 0x80, 0xf0, 0x40, 0x00, 0xf0}; } }; #end namespace ::Widget::Progressbar |
Added library/tabnotebook.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 | ## ## Copyright 1997-8 Jeffrey Hobbs, [email protected], CADIX International ## package require Widget 2.0 package provide Tabnotebook 2.0 ## FIX: ## option state of subitems could be kept in a clearer array ## -relief for .tab.hold should be flat initially ##------------------------------------------------------------------------ ## PROCEDURE ## tabnotebook ## ## DESCRIPTION ## Implements a Tabbed Notebook megawidget ## ## ARGUMENTS ## tabnote <window pathname> <options> ## ## OPTIONS ## (Any entry widget option may be used in addition to these) ## ## -activebackground color DEFAULT: {} ## The background color given to the active tab. A value of {} ## means these items will pick up the widget's background color. ## ## -background color DEFAULT: DEFAULT ## The background color for the container subwidgets. ## ## -browsecmd script DEFAULT: {} ## A script that is evaluated each time a tab changes. It appends ## the old tab and the new tab to the script. An empty string ({}) ## represents the blank (empty) tab. This is eval'ed before the ## tab actually changes, allowing tab transitions to be aborted by ## returning an error value in this script. ## ## -disabledbackground color DEFAULT: #c0c0c0 (dark gray) ## The background color given to disabled tabs. ## ## -font DEFAULT: {Helvetica -12} ## The font for the tab text. All tabs use the same font. ## ## -justify justification DEFAULT: center ## The justification applied to the text in multi-line tabs. ## Must be one of: left, right, center. ## ## -linewidth pixels DEFAULT: 2 ## The width of the line surrounding the tabs. Must be at least 1. ## ## -linecolor color DEFAULT: black ## The color of the line surrounding the tabs. ## ## -normalbackground DEFAULT: {} ## The background color of items with normal state. A value of {} ## means these items will pick up the widget's background color. ## ## -padx pixels DEFAULT: 8 ## The X padding for folder tabs around the items. ## ## -pady pixels DEFAULT: 6 ## The Y padding for folder tabs around the items. ## ## RETURNS: the window pathname ## ## BINDINGS (in addition to default widget bindings) ## ## <1> in a tabs activates that tab. ## ## METHODS ## These are the methods that the Tabnote widget recognizes. Aside from ## these, it accepts methods that are valid for entry widgets. ## ## activate id ## Activates the tab specified by id. id may either by the unique id ## returned by the add command or the string used in the add command. ## ## add string ?options? ## Adds a tab to the tab notebook with the specified string, unless ## the string is the name of an image, in which case the image is used. ## Each string must be unique. See ITEM OPTIONS for the options. ## A unique tab id is returned. ## ## delete id ## Deletes the tab specified by id. id may either by the unique id ## returned by the add command or the string used in the add command. ## ## itemconfigure ?option? ?value option value ...? ## itemcget option ## Configure or retrieve the option of a tab notebook item. ## ## name tabId ## Returns the text name for a given tabId. ## ## subwidget widget ## Returns the true widget path of the specified widget. Valid ## widgets are hold (a frame), tabs (a canvas), blank (a frame). ## ## ITEM OPTIONS ## These are options for the items (tabs) of the notebook ## ## -window widget DEFAULT: {} ## Specifies the widget to show when the tab is pressed. It must be ## a child of the tab notebook (required for grid management) and exist ## prior to this command. ## ## -state normal|disabled|active DEFAULT: normal ## The optional state can be normal, active or disabled. ## If active, then this tab becomes the active (displayed) tab. ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ## EXAMPLE USAGE: ## ## pack [tabnotebook .t] -fill both -expand 1 ## text .t.t -height 10 -width 20 ## .t add "Text Widget" -window .t.t ##------------------------------------------------------------------------ # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc Tabnotebook args {} proc tabnotebook args {} widget create Tabnotebook -type frame -base frame -components { {frame hold hold {-relief raised -bd 1}} {frame blank} {frame hide hide {-background $data(-background) -height 1 -width 40}} {canvas tabs tabs {-bg $data(-background) -highlightthick 0 -takefocus 0}} } -options { {-activebackground activeBackground ActiveBackground {}} {-bg -background} {-background ALIAS frame -background} {-bd -borderwidth} {-borderwidth ALIAS frame -borderwidth} {-browsecmd browseCmd BrowseCommand {}} {-disabledbackground disabledBackground DisabledBackground #a3a3a3} {-normalbackground normalBackground normalBackground #c3c3c3} {-font font Font {Helvetica -12}} {-justify justify Justify center} {-minwidth minWidth Width -1} {-minheight minHeight Height -1} {-padx padX PadX 8} {-pady padY PadY 6} {-relief ALIAS frame -relief} {-linewidth lineWidth LineWidth 2} {-linecolor lineColor LineColor black} } namespace eval ::Widget::Tabnotebook {; ;proc construct {w} { upvar \#0 [namespace current]::$w data ## Private variables array set data { curtab {} numtabs 0 width 0 height 0 ids {} } $data(tabs) itemconfigure TEXT -font $data(-font) $data(tabs) yview moveto 0 $data(tabs) xview moveto 0 grid $data(tabs) -sticky ew grid $data(hold) -sticky news grid $data(blank) -in $data(hold) -row 0 -column 0 -sticky nsew grid columnconfig $w 0 -weight 1 grid rowconfigure $w 1 -weight 1 grid columnconfig $data(hold) 0 -weight 1 grid rowconfigure $data(hold) 0 -weight 1 bind $data(tabs) <Configure> [namespace code \ "if {!\[string compare $data(tabs) %W\]} { resize [list $w] %w }"] bind $data(tabs) <2> { %W scan mark %x 0 } bind $data(tabs) <B2-Motion> [namespace code { %W scan dragto %x 0 resize [winfo parent %W] [winfo width %W] } ] } ;proc configure {w args} { upvar \#0 [namespace current]::$w data set truth {^(1|yes|true|on)$} set post {} foreach {key val} $args { switch -- $key { -activebackground { if {[string compare $data(curtab) {}]} { $data(tabs) itemconfig POLY:$data(curtab) -fill $val } if {[string compare $val {}]} { $data(hide) config -bg $val } else { lappend post \ [list $data(hide) config -bg $data(-background)] } } -background { $data(tabs) config -bg $val $data(hold) config -bg $val $data(blank) config -bg $val } -borderwidth { $data(hold) config -bd $val $data(hide) config -height $val } -disabledbackground { foreach i $data(ids) { if {[string match disabled $data(:$i:-state)]} { $data(tabs) itemconfig POLY:$i -fill $val } } } -font { $data(tabs) itemconfigure TEXT -font $val recalculate $w } -justify { $data(tabs) itemconfigure TEXT -justify $val } -linewidth { $data(tabs) itemconfigure LINE -width $val } -linecolor { $data(tabs) itemconfigure LINE -fill $val } -minwidth { if {$val < 0} { set val 0 } grid columnconfig $w 0 -minsize $val } -minheight { if {$val < 0} { set val 0 } grid rowconfigure $w 1 -minsize $val } -normalbackground { foreach i $data(ids) { if {[string match normal $data(:$i:-state)]} { $data(tabs) itemconfig POLY:$i -fill $val } } } -padx - -pady { if {$val < 1} { set val 1 } } -relief { $data(hold) config -relief $val } } set data($key) $val } if {[string compare $post {}]} { eval [join $post \n] } } ;proc _add { w text args } { upvar \#0 [namespace current]::$w data set c $data(tabs) if {[string match {} $text]} { return -code error "non-empty text required for noteboook label" } elseif {[string compare {} [$c find withtag ID:$text]]} { return -code error "tab \"$text\" already exists" } array set s { -window {} -state normal } foreach {key val} $args { switch -glob -- $key { -w* { if {[string compare $val {}]} { if {![winfo exist $val]} { return -code error "window \"$val\" does not exist" } elseif {[string comp $w [winfo parent $val]] && \ [string comp $data(hold) [winfo parent $val]]} { return -code error "window \"$val\" must be a\ child of the tab notebook ($w)" } } set s(-window) $val } -s* { if {![regexp {^(normal|disabled|active)$} $val]} { return -code error "unknown state \"$val\", must be:\ normal, disabled or active" } set s(-state) $val } default { return -code error "unknown option '$key', must be:\ [join [array names s] {, }]" } } } set tab [incr data(numtabs)] set px [expr {int(ceil($data(-padx)/2))}] set py [expr {int(ceil($data(-pady)/2))}] if {[lsearch -exact [image names] $text] != -1} { set i [$c create image $px $py -image $text -anchor nw \ -tags [list IMG M:$tab ID:$text TAB:$tab]] } else { set i [$c create text [expr {$px+1}] $py -text $text -anchor nw \ -tags [list TEXT M:$tab ID:$text TAB:$tab] \ -justify $data(-justify) -font $data(-font)] } foreach {x1 y1 x2 y2} [$c bbox $i] { set W [expr {$x2-$x1+$px}] set FW [expr {$W+$px}] set FH [expr {$y2-$y1+3*$py}] } set diff [expr {$FH-$data(height)}] if {$diff > 0} { $c move all 0 $diff $c move $i 0 -$diff set data(height) $FH } $c create poly 0 $FH $px $py $W $py $FW $FH -fill {} \ -tags [list POLY POLY:$tab TAB:$tab] $c create line 0 $FH $px $py $W $py $FW $FH -joinstyle round \ -tags [list LINE LINE:$tab TAB:$tab] \ -width $data(-linewidth) -fill $data(-linecolor) $c move TAB:$tab $data(width) [expr {($diff<0)?-$diff:0}] $c raise $i $c raise LINE:$tab incr data(width) $FW $c configure -width $data(width) -height $data(height) \ -scrollregion "0 0 $data(width) $data(height)" $c bind TAB:$tab <1> [namespace code [list _activate $w $tab]] array set data [list :$tab:-window $s(-window) :$tab:-state $s(-state)] if {[string compare $s(-window) {}]} { grid $s(-window) -in $data(hold) -row 0 -column 0 -sticky nsew lower $s(-window) } switch $s(-state) { active {_activate $w $tab} disabled {$c itemconfig POLY:$tab -fill $data(-disabledbackground)} normal {$c itemconfig POLY:$tab -fill $data(-normalbackground)} } lappend data(ids) $tab return $tab } ;proc _activate { w id } { upvar \#0 [namespace current]::$w data if {[string compare $id {}]} { set tab [verify $w $id] if {[string match disabled $data(:$tab:-state)]} return } else { set tab {} } if {[string compare $data(-browsecmd) {}] && \ [catch {uplevel \#0 $data(-browsecmd) \ [list [_name $w $data(curtab)] [_name $w $tab]]}]} { return } if {[string match $data(curtab) $tab]} return set c $data(tabs) set oldtab $data(curtab) if {[string compare $oldtab {}]} { $c itemconfig POLY:$oldtab -fill $data(-normalbackground) $c move TAB:$oldtab 0 2 set data(:$oldtab:-state) normal } set data(curtab) $tab if {[string compare $tab {}]} { set data(:$tab:-state) active $c itemconfig POLY:$tab -fill $data(-activebackground) $c move TAB:$tab 0 -2 } if {[info exists data(:$tab:-window)] && \ [winfo exists $data(:$tab:-window)]} { raise $data(:$tab:-window) } else { raise $data(blank) } resize $w [winfo width $w] } ;proc _delete { w id } { upvar \#0 [namespace current]::$w data set tab [verify $w $id] set c $data(tabs) foreach {x1 y1 x2 y2} [$c bbox TAB:$tab] { set W [expr {$x2-$x1-3}] } $c delete TAB:$tab for { set i [expr {$tab+1}] } { $i <= $data(numtabs) } { incr i } { $c move TAB:$i -$W 0 } foreach {x1 y1 x2 y2} [$c bbox all] { set H [expr {$y2-$y1-3}] } if {$H<$data(height)} { $c move all 0 [expr {$H-$data(height)}] set data(height) $H } incr data(width) -$W $c config -width $data(width) -height $data(height) \ -scrollregion "0 0 $data(width) $data(height)" set i [lsearch $data(ids) $tab] set data(ids) [lreplace $data(ids) $i $i] catch {grid forget $data(:$tab:-window)} unset data(:$tab:-state) data(:$tab:-window) if {[string match $tab $data(curtab)]} { set data(curtab) {} raise $data(blank) } } ;proc _itemcget { w id key } { upvar \#0 [namespace current]::$w data set tab [verify $w $id] set opt [array names data :$tab:$key*] set len [llength $opt] if {$len == 1} { return $data($opt) } elseif {$len == 0} { set all [array names data :$tab:-*] foreach o $all { lappend opts [lindex [split $o :] end] } return -code error "unknown option \"$key\", must be one of:\ [join $opts {, }]" } else { foreach o $opt { lappend opts [lindex [split $o :] end] } return -code error "ambiguous option \"$key\", must be one of:\ [join $opts {, }]" } } ;proc _itemconfigure { w id args } { upvar \#0 [namespace current]::$w data set tab [verify $w $id] set len [llength $args] if {$len == 1} { return [uplevel 1 _itemcget $w $tab $args] } elseif {$len&1} { return -code error "uneven set of key/value pairs in \"$args\"" } if {[string match {} $args]} { set all [array names data :$tab:-*] foreach o $all { lappend res [lindex [split $o :] end] $data($o) } return $res } foreach {key val} $args { switch -glob -- $key { -w* { if {[string comp $val {}]} { if {![winfo exist $val]} { return -code error "window \"$val\" does not exist" } elseif {[string comp $w [winfo parent $val]] && \ [string comp $data(hold) [winfo parent $val]]} { return -code error "window \"$val\" must be a\ child of the tab notebook ($w)" } } set old $data(:$tab:-window) if {[winfo exists $old]} { grid forget $old } set data(:$tab:-window) $val if {[string comp $val {}]} { grid $val -in $data(hold) -row 0 -column 0 \ -sticky nsew lower $val } if {[string match active $data(:$tab:-state)]} { if {[string comp $val {}]} { raise $val } else { raise $data(blank) } } } -s* { if {![regexp {^(normal|disabled|active)$} $val]} { return -code error "unknown state \"$val\", must be:\ normal, disabled or active" } if {[string match $val $data(:$tab:-state)]} return set old $data(:$tab:-state) switch $val { active { set data(:$tab:-state) $val _activate $w $tab } disabled { if {[string match active $old]} { _activate $w {} } $data(tabs) itemconfig POLY:$tab \ -fill $data(-disabledbackground) set data(:$tab:-state) $val } normal { if {[string match active $old]} { _activate $w {} } $data(tabs) itemconfig POLY:$tab -fill {} set data(:$tab:-state) $val } } } default { return -code error "unknown option '$key', must be:\ [join [array names s] {, }]" } } } } ## given a tab number, return the text ;proc _name { w id } { upvar \#0 [namespace current]::$w data if {[string match {} $id]} return set text {} foreach item [$data(tabs) find withtag TAB:$id] { set tags [$data(tabs) gettags $item] if {[set i [lsearch -glob $tags {ID:*}]] != -1} { set text [string range [lindex $tags $i] 3 end] break } } return $text } #;proc _order {w args} { # upvar \#0 [namespace current]::$w data # # foreach i $data(ids) { # } #} ## Take all the tabs and reculate space requirements ;proc recalculate {w} { upvar \#0 [namespace current]::$w data set c $data(tabs) set px [expr {int(ceil($data(-padx)/2))}] set py [expr {int(ceil($data(-pady)/2))}] set data(width) 0 set data(height) 0 foreach i $data(ids) { $c coords M:$i [expr \ {[string match text [$c type M:$i]]?$px+1:$px}] $py foreach {x1 y1 x2 y2} [$c bbox M:$i] { set W [expr {$x2-$x1+$px}] set FW [expr {$W+$px}] set FH [expr {$y2-$y1+3*$py}] } set diff [expr {$FH-$data(height)}] if {$diff > 0} { $c move all 0 $diff $c move M:$i 0 -$diff set data(height) $FH } $c coords POLY:$i 0 $FH $px $py $W $py $FW $FH $c coords LINE:$i 0 $FH $px $py $W $py $FW $FH $c move TAB:$i $data(width) [expr {($diff<0)?-$diff:0}] incr data(width) $FW } $c configure -width $data(width) -height $data(height) \ -scrollregion "0 0 $data(width) $data(height)" } ;proc resize {w x} { upvar \#0 [namespace current]::$w data if {[string compare $data(curtab) {}]} { set x [expr {round(-[$data(tabs) canvasx 0])}] foreach {x1 y1 x2 y2} [$data(tabs) bbox TAB:$data(curtab)] { place $data(hide) -y [winfo y $data(hold)] -x [expr {$x1+$x+3}] $data(hide) config -width [expr {$x2-$x1-5}] } } else { place forget $data(hide) } } ;proc see {w id} { upvar \#0 [namespace current]::$w data set c $data(tabs) set box [$c bbox $id] if {[string match {} $box]} return foreach {x y x1 y1} $box {left right} [$c xview] \ {p q xmax ymax} [$c cget -scrollregion] { set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}] } $c xview moveto $xpos } ;proc verify { w id } { upvar \#0 [namespace current]::$w data set c $data(tabs) if {[string compare [set i [$c find withtag ID:$id]] {}]} { if {[regexp {TAB:([0-9]+)} [$c gettags [lindex $i 0]] junk id]} { return $id } } elseif {[string compare [$c find withtag TAB:$id] {}]} { return $id } return -code error "unrecognized tab \"$id\"" } }; #end of namespace ::Widget::Tabnotebook |
Added library/util-color.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | # util-color.tcl -- # # This file implements package ::Utility::color, which ... # # Copyright (c) 1998 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # #package require NAME VERSION package require Tk package provide ::Utility::color 1.0; # SET VERSION namespace eval ::Utility::color {; namespace export -clear * # rgb2dec -- # # Turns #rgb into 3 elem list of decimal vals. # # Arguments: # c The #rgb hex of the color to translate # Results: # Returns a #RRGGBB or #RRRRGGGGBBBB color # proc rgb2dec c { set c [string tolower $c] if {[regexp {^\#([0-9a-f])([0-9a-f])([0-9a-f])$} $c x r g b]} { # double'ing the value make #9fc == #99ffcc scan "$r$r $g$g $b$b" "%x %x %x" r g b } else { if {![regexp {^\#([0-9a-f]+)$} $c junk hex] || \ [set len [string length $hex]]>12 || $len%3 != 0} { return -code error "bad color value \"$c\"" } set len [expr {$len/3}] scan $hex "%${len}x%${len}x%${len}x" r g b } return [list $r $g $b] } # dec2rgb -- # # Takes a color name or dec triplet and returns a #RRGGBB color. # If any of the incoming values are greater than 255, # then 16 bit value are assumed, and #RRRRGGGGBBBB is # returned, unless $clip is set. # # Arguments: # r red dec value, or list of {r g b} dec value or color name # g green dec value, or the clip value, if $r is a list # b blue dec value # clip Whether to force clipping to 2 char hex # Results: # Returns a #RRGGBB or #RRRRGGGGBBBB color # proc dec2rgb {r {g 0} {b UNSET} {clip 0}} { if {![string compare $b "UNSET"]} { set clip $g if {[regexp {^-?(0-9)+$} $r]} { foreach {r g b} $r {break} } else { foreach {r g b} [winfo rgb . $r] {break} } } set max 255 set len 2 if {($r > 255) || ($g > 255) || ($b > 255)} { if {$clip} { set r [expr {$r>>8}]; set g [expr {$g>>8}]; set b [expr {$b>>8}] } else { set max 65535 set len 4 } } return [format "#%.${len}X%.${len}X%.${len}X" \ [expr {($r>$max)?$max:(($r<0)?0:$r)}] \ [expr {($g>$max)?$max:(($g<0)?0:$g)}] \ [expr {($b>$max)?$max:(($b<0)?0:$b)}]] } # shade -- # # Returns a shade between two colors # # Arguments: # orig start #rgb color # dest #rgb color to shade towards # frac fraction (0.0-1.0) to move $orig towards $dest # Results: # Returns a shade between two colors based on the # proc shade {orig dest frac} { if {$frac >= 1.0} { return $dest } elseif {$frac <= 0.0} { return $orig } foreach {origR origG origB} [rgb2dec $orig] \ {destR destG destB} [rgb2dec $dest] { set shade [format "\#%02x%02x%02x" \ [expr {int($origR+double($destR-$origR)*$frac)}] \ [expr {int($origG+double($destG-$origG)*$frac)}] \ [expr {int($origB+double($destB-$origB)*$frac)}]] return $shade } } # complement -- # # Returns a complementary color # Does some magic to avoid bad complements of grays # # Arguments: # orig start #rgb color # Results: # Returns a complement of a color # proc complement {orig {grays 1}} { foreach {r g b} [rgb2dec $orig] {break} set R [expr {(~$r)%256}] set G [expr {(~$g)%256}] set B [expr {(~$b)%256}] if {$grays && abs($R-$r) < 32 && abs($G-$g) < 32 && abs($B-$b) < 32} { set R [expr {($r+128)%256}] set G [expr {($g+128)%256}] set B [expr {($b+128)%256}] } return [format "\#%02x%02x%02x" $R $G $B] } # hsv2rgb -- # # Convert hsv to rgb # # Arguments: # h hue # s saturation # v value # Results: # Returns an rgb triple from hsv # proc hsv2rgb {h s v} { if {$s <= 0.0} { # achromatic set v [expr int($v)] return "$v $v $v" } else { set v [expr double($v)] if {$h >= 1.0} { set h 0.0 } set h [expr 6.0 * $h] set f [expr double($h) - int($h)] set p [expr int(256 * $v * (1.0 - $s))] set q [expr int(256 * $v * (1.0 - ($s * $f)))] set t [expr int(256 * $v * (1.0 - ($s * (1.0 - $f))))] set v [expr int(256 * $v)] switch [expr int($h)] { 0 { return "$v $t $p" } 1 { return "$q $v $p" } 2 { return "$p $v $t" } 3 { return "$p $q $v" } 4 { return "$t $p $v" } 5 { return "$v $p $q" } } } } proc hls2rgb {h l s} { # Posted by [email protected] # h, l and s are floats between 0.0 and 1.0, ditto for r, g and b # h = 0 => red # h = 1/3 => green # h = 2/3 => blue set h6 [expr {($h-floor($h))*6}] set r [expr { $h6 <= 3 ? 2-$h6 : $h6-4}] set g [expr { $h6 <= 2 ? $h6 : $h6 <= 5 ? 4-$h6 : $h6-6}] set b [expr { $h6 <= 1 ? -$h6 : $h6 <= 4 ? $h6-2 : 6-$h6}] set r [expr {$r < 0.0 ? 0.0 : $r > 1.0 ? 1.0 : double($r)}] set g [expr {$g < 0.0 ? 0.0 : $g > 1.0 ? 1.0 : double($g)}] set b [expr {$b < 0.0 ? 0.0 : $b > 1.0 ? 1.0 : double($b)}] set r [expr {(($r-1)*$s+1)*$l}] set g [expr {(($g-1)*$s+1)*$l}] set b [expr {(($b-1)*$s+1)*$l}] return [list $r $g $b] } }; # end of namespace ::Utility::color |
Added library/util-dump.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 | # util-dump.tcl -- # # This file implements package ::Utility::dump, which ... # # Copyright (c) 1997-8 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require ::Utility package provide ::Utility::dump 1.0 namespace eval ::Utility::dump {; namespace export -clear dump* namespace import -force ::Utility::get_opts* # dump -- # outputs recognized item info in source'able form. # Accepts glob style pattern matching for the names # Arguments: # type type of item to dump # -nocomplain # -filter pattern # specifies a glob filter pattern to be used by the variable # method as an array filter pattern (it filters down for # nested elements) and in the widget method as a config # option filter pattern # -procs # -vars # -recursive # -imports # -- forcibly ends options recognition # Results: # the values of the requested items in a 'source'able form ;proc dump {type args} { if {![llength $args]} { ## If no args, assume they gave us something to dump and ## we'll try anything set args [list $type] set type multi } ## Args are handled individually by the routines because of the ## variable parameters for each type set prefix [namespace current]::dump_ if {[string match {} [set arg [info commands $prefix$type]]]} { set arg [info commands $prefix$type*] } set result {} set code ok switch [llength $arg] { 1 { set code [catch {uplevel $arg $args} result] } 0 { set arg [info commands $prefix*] regsub -all $prefix $arg {} arg return -code error "unknown [lindex [info level 0] 0] type\ \"$type\", must be one of: [join [lsort $arg] {, }]" } default { regsub -all $prefix $arg {} arg return -code error "ambiguous type \"$type\",\ could be one of: [join [lsort $arg] {, }]" } } return -code $code $result } # dump_multi -- # # Tries to work the args into one of the main dump types: # variable, command, widget, namespace # # Arguments: # args comments # Results: # Returns ... # proc dump_multi {args} { array set opts { -nocomplain 0 } set namesp [namespace current] set args [get_opts opts $args {-nocomplain 0} {} 1] set code ok if { [catch {uplevel ${namesp}::dump var $args} err] && [catch {uplevel ${namesp}::dump com $args} err] && [catch {uplevel ${namesp}::dump wid $args} err] && [catch {uplevel ${namesp}::dump nam $args} err] } { set result "# unable to resolve type for \"$args\"\n" if {!$opts(-nocomplain)} { set code error } } else { set result $err } return -code $code [string trimright $result \n] } # dump_command -- # # outputs commands by figuring out, as well as possible, # it does not attempt to auto-load anything # # Arguments: # args comments # Results: # Returns ... # proc dump_command {args} { array set opts { -nocomplain 0 -origin 0 } set args [get_opts opts $args {-nocomplain 0 -origin 0}] if {[string match {} $args]} { if {$opts(-nocomplain)} { return } else { return -code error "wrong \# args: dump command ?-nocomplain?" } } set code ok set result {} set namesp [namespace current] foreach arg $args { if {[string compare {} [set cmds \ [uplevel info command [list $arg]]]]} { foreach cmd [lsort $cmds] { if {[lsearch -exact [interp aliases] $cmd] > -1} { append result "\#\# ALIAS: $cmd =>\ [interp alias {} $cmd]\n" } elseif {![catch {uplevel ${namesp}::dump_proc \ [expr {$opts(-origin)?{-origin}:{}}] \ -- [list $cmd]} msg]} { append result $msg\n } else { if {$opts(-origin) || [string compare $namesp \ [uplevel namespace current]]} { set cmd [uplevel namespace origin [list $cmd]] } append result "\#\# COMMAND: $cmd\n" } } } elseif {!$opts(-nocomplain)} { append result "\#\# No known command $arg\n" set code error } } return -code $code [string trimright $result \n] } # dump_proc -- # # ADD COMMENTS HERE # # Arguments: # args comments # Results: # Returns ... # proc dump_proc {args} { array set opts { -nocomplain 0 -origin 0 } set args [get_opts opts $args {-nocomplain 0 -origin 0}] if {[string match {} $args]} { if {$opts(-nocomplain)} { return } else { return -code error "wrong \# args: dump proc ?-nocomplain?" } } set code ok set result {} foreach arg $args { set procs [uplevel info command [list $arg]] set count 0 if {[string compare $procs {}]} { foreach p [lsort $procs] { set cmd [uplevel namespace origin [list $p]] set namesp [namespace qualifiers $cmd] if {[string match {} $namesp]} { set namesp :: } if {[string compare [namespace eval $namesp \ info procs [list [namespace tail $cmd]]] {}]} { incr count } else { continue } set pargs {} foreach a [info args $cmd] { if {[info default $cmd $a tmp]} { lappend pargs [list $a $tmp] } else { lappend pargs $a } } if {$opts(-origin) || [string compare $namesp \ [uplevel namespace current]]} { ## This is ideal, but list can really screw with the ## format of the body for some procs with odd whitespacing ## (everything comes out backslashed) #append result [list proc $cmd $pargs [info body $cmd]] append result [list proc $cmd $pargs] } else { ## We don't include the full namespace qualifiers ## if we are in the namespace of origin #append result [list proc $p $pargs [info body $cmd]] append result [list proc $p $pargs] } append result " \{[info body $cmd]\}\n\n" } } if {!$count && !$opts(-nocomplain)} { append result "\#\# No known proc $arg\n" set code error } } return -code $code [string trimright $result \n] } # dump_variable -- # # outputs variable value(s), whether array or simple, namespaced or otherwise # # Arguments: # -nocomplain # don't complain if no vars match something # -filter pattern # specifies a glob filter pattern to be used by the variable # method as an array filter pattern (it filters down for # nested elements) and in the widget method as a config # option filter pattern # -compact # makes a more compact output format to save bytes for large # files that are only to be sourced in # -append # user 'append' rather than set for simple vars # -lappend # user 'lappend' rather than set for simple vars # -- forcibly ends options recognition # Returns: # the values of the requested items in a 'source'able form # proc dump_variable {args} { set whine 1 set code ok set compact { } set SET "set" while {[string match -* $args]} { switch -glob -- [lindex $args 0] { -n* { set whine 0; set args [lreplace $args 0 0] } -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } -c* { set compact {}; set args [lreplace $args 0 0] } -l* { set SET lappend; set args [lreplace $args 0 0] } -a* { set SET append; set args [lreplace $args 0 0] } -- { set args [lreplace $args 0 0]; break } default {return -code error "unknown option \"[lindex $args 0]\""} } } if {$whine && [string match {} $args]} { return -code error "wrong \# args: [lindex [info level 0] 0] type\ ?-append? ?-compact? ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?" } # variable # outputs variables value(s), whether array or simple. if {![info exists fltr]} { set fltr * } foreach arg $args { if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { if {[uplevel info exists $arg]} { set vars $arg } elseif {$whine} { append res "\#\# No known variable $arg\n" set code error continue } else { continue } } foreach var [lsort -dictionary $vars] { set var [uplevel [list namespace which -variable $var]] upvar $var v if {[array exists v] || [catch {string length $v}]} { append res "array set [list $var] \{\n" foreach i [lsort -dictionary [array names v $fltr]] { append res "${compact}[list $i]\t[list $v($i)]\n" } append res "\}\n" } elseif {[string compare set $SET]} { append res [list $SET $var] { } $v\n } else { append res [list set $var $v]\n } } } return -code $code [string trimright $res \n] } # dump_namespace -- # # ADD COMMENTS HERE # # Arguments: # args comments # Results: # Returns ... # proc dump_namespace {args} { array set opts { -nocomplain 0 -filter * -procs 1 -vars 1 -recursive 0 -imports 1 } set args [get_opts opts $args {-nocomplain 0 -procs 1 -vars 1 \ -recursive 0 -imports 1} {-procs boolean -vars boolean \ -imports boolean}] if {[string match {} $args]} { if {$opts(-nocomplain)} { return } else { return -code error "wrong \# args: dump namespace ?-nocomplain?\ ?-procs 0/1? ?-vars 0/1? ?-recursive? ?-imports 0/1?\ ?--? pattern ?pattern ...?" } } set code ok set result {} foreach arg $args { set cur [uplevel namespace current] # Namespace search order: # If it starts with ::, try and break it apart and see if we find # children matching the pattern # Then do the same in $cur if it has :: anywhere in it # Then look in the calling namespace for children matching $arg # Then look in the global namespace for children matching $arg if { ([string match ::* $arg] && [catch [list namespace children [namespace qualifiers $arg] \ [namespace tail $arg]] names]) && ([string match *::* $arg] && [catch [list namespace eval $cur [list namespace children \ [namespace qualifiers $arg] \ [namespace tail $arg]] names]]) && [catch [list namespace children $cur $arg] names] && [catch [list namespace children :: $arg] names] } { if {!$opts(-nocomplain)} { append result "\#\# No known namespace $arg\n" set code error } } if {[string compare $names {}]} { set count 0 foreach name [lsort $names] { append result "namespace eval $name \{;\n\n" if {$opts(-vars)} { set vars [lremove [namespace eval $name info vars] \ [info globals]] append result [namespace eval $name \ [namespace current]::dump_variable [lsort $vars]]\n } set procs [namespace eval $name info procs] if {$opts(-procs)} { set export [namespace eval $name namespace export] if {[string compare $export {}]} { append result "namespace export -clear $export\n\n" } append result [namespace eval $name \ [namespace current]::dump_proc [lsort $procs]] } if {$opts(-imports)} { set cmds [info commands ${name}::*] regsub -all ${name}:: $cmds {} cmds set cmds [lremove $cmds $procs] foreach cmd [lsort $cmds] { set cmd [namespace eval $name \ [list namespace origin $cmd]] if {[string compare $name \ [namespace qualifiers $cmd]]} { ## Yup, it comes from somewhere else append result [list namespace import -force $cmd] } else { ## It is probably an alias set alt [interp alias {} $cmd] if {[string compare $alt {}]} { append result "interp alias {} $cmd {} $alt" } else { append result "# CANNOT HANDLE $cmd" } } append result \n } append result \n } if {$opts(-recursive)} { append result [uplevel [namespace current]::dump_namespace\ [namespace children $name]] } append result "\}; # end of namespace $name\n\n" } } elseif {!$opts(-nocomplain)} { append result "\#\# No known namespace $arg\n" set code error } } return -code $code [string trimright $result \n] } # dump_widget -- # Outputs a widget configuration in source'able but human readable form. # Arguments: # args comments # Results: # Returns widget configuration in "source"able form. # proc dump_widget {args} { if {[string match {} [info command winfo]]} { return -code error "winfo not present, cannot dump widgets" } array set opts { -nocomplain 0 -filter .* -default 0 } set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0} \ {-filter regexp}] if {[string match {} $args]} { if {$opts(-nocomplain)} { return } else { return -code error "wrong \# args: dump widget ?-nocomplain?\ ?-default? ?-filter regexp? ?--? pattern ?pattern ...?" } } set code ok set result {} foreach arg $args { if {[string compare {} [set ws [info command $arg]]]} { foreach w [lsort $ws] { if {[winfo exists $w]} { if {[catch {$w configure} cfg]} { append result "\#\# Widget $w\ does not support configure method" if {!$opts(-nocomplain)} { set code error } } else { append result "\#\# [winfo class $w] $w\n$w configure" foreach c $cfg { if {[llength $c] != 5} continue ## Filter options according to user provided ## filter, and then check to see that they ## are a default if {[regexp -nocase -- $opts(-filter) $c] && \ ($opts(-default) || [string compare \ [lindex $c 3] [lindex $c 4]])} { append result " \\\n\t[list [lindex $c 0]\ [lindex $c 4]]" } } append result \n } } } } elseif {!$opts(-nocomplain)} { append result "\#\# No known widget $arg\n" set code error } } return -code $code [string trimright $result \n] } # dump_canvas -- # # ADD COMMENTS HERE # # Arguments: # args comments # Results: # Returns ... # proc dump_canvas {args} { if {[string match {} [info command winfo]]} { return -code error "winfo not present, cannot dump widgets" } array set opts { -nocomplain 0 -default 0 -configure 0 -filter .* } set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0 \ -configure 0} {-filter regexp}] if {[string match {} $args]} { if {$opts(-nocomplain)} { return } else { return -code error "wrong \# args: dump canvas ?-nocomplain?\ ?-configure? ?-default? ?-filter regexp? ?--? pattern\ ?pattern ...?" } } set code ok set result {} foreach arg $args { if {[string compare {} [set ws [info command $arg]]]} { foreach w [lsort $ws] { if {[winfo exists $w]} { if {[string compare Canvas [winfo class $w]]} { append result "\#\# Widget $w is not a canvas widget" if {!$opts(-nocomplain)} { set code error } } else { if {$opts(-configure)} { append result [dump_widget -filter $opts(-filter) \ [expr {$opts(-default)?{-default}:{-no}}] \ $w] append result \n } else { append result "\#\# Canvas $w items\n" } ## Output canvas items in numerical order foreach i [lsort -integer [$w find all]] { append result "\#\# Canvas item $i\n" \ "$w create [$w type $i] [$w coords $i]" foreach c [$w itemconfigure $i] { if {[llength $c] != 5} continue if {$opts(-default) || [string compare \ [lindex $c 3] [lindex $c 4]]} { append result " \\\n\t[list [lindex $c 0]\ [lindex $c 4]]" } } append result \n } } } } } elseif {!$opts(-nocomplain)} { append result "\#\# No known widget $arg\n" set code error } } return -code $code [string trimright $result \n] } # dump_text -- # # ADD COMMENTS HERE # # Arguments: # args comments # Results: # Returns ... # proc dump_text {args} { if {[string match {} [info command winfo]]} { return -code error "winfo not present, cannot dump widgets" } array set opts { -nocomplain 0 -default 0 -configure 0 -start 1.0 -end end } set args [get_opts opts $args {-nocomplain 0 -default 0 \ -configure 0 -start 1 -end 1}] if {[string match {} $args]} { if {$opts(-nocomplain)} { return } else { return -code error "wrong \# args: dump text ?-nocomplain?\ ?-configure? ?-default? ?-filter regexp? ?--? pattern\ ?pattern ...?" } } set code ok set result {} foreach arg $args { if {[string compare {} [set ws [info command $arg]]]} { foreach w [lsort $ws] { if {[winfo exists $w]} { if {[string compare Text [winfo class $w]]} { append result "\#\# Widget $w is not a text widget" if {!$opts(-nocomplain)} { set code error } } else { if {$opts(-configure)} { append result [dump_widget -filter $opts(-filter) \ [expr {$opts(-default)?{-default}:{-no}}] \ $w] append result \n } else { append result "\#\# Text $w dump\n" } catch {unset tags} catch {unset marks} set text {} foreach {k v i} [$w dump $opts(-start) $opts(-end)] { switch -exact $k { text { append text $v } window { # must do something with windows # will require extra options to determine # whether to rebuild the window or to # just reference it append result "#[list $w] window create\ $i [$w window configure $i]\n" } mark {set marks($v) $i} tagon {lappend tags($v) $i} tagoff {lappend tags($v) $i} default { error "[info level 0]:\ should not be in this switch arm" } } } append result "[list $w insert $opts(-start) $text]\n" foreach i [$w tag names] { append result "[list $w tag configure $i]\ [$w tag configure $i]\n" if {[info exists tags($i)]} { append result "[list $w tag add $i]\ $tags($i)\n" } foreach seq [$w tag bind $i] { append result "[list $w tag bind $i $seq \ [$w tag bind $i $seq]]\n" } } foreach i [array names marks] { append result "[list $w mark set $i $marks($i)]\n" } } } } } elseif {!$opts(-nocomplain)} { append result "\#\# No known widget $arg\n" set code error } } return -code $code [string trimright $result \n] } # dump_interface -- NOT FUNCTIONAL # # the end-all-be-all of Tk dump commands. This should dump the widgets # of an interface with all the geometry management. # # Arguments: # args comments # Results: # Returns ... # proc dump_interface {args} { } # dump_state -- # # This dumps the state of an interpreter. This is primarily a wrapper # around other dump commands with special options. # # Arguments: # args comments # Results: # Returns ... # proc dump_state {args} { } ## Force the parent namespace to include the exported commands ## catch {namespace eval ::Utility namespace import -force ::Utility::dump::*} }; # end of namespace ::Utility::dump return |
Added library/util-expand.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 | # util-expand.tcl -- # # This file implements package ::Utility::expand, which ... # # Copyright (c) 1997-8 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require ::Utility package provide ::Utility::expand 1.0 namespace eval ::Utility::expand {; namespace export -clear expand* namespace import -force ::Utility::* ## ## NOTE: In places where uplevel is used, it is highly likely that ## a further eval redirect is otherwise necessary for foreign interps ## # expand -- # # The string to match is expanded to the longest possible match. # If data(-showmultiple) is non-zero and the user longest match # equaled the string to expand, then all possible matches are # output to stdout. Triggers bell if no matches are found. # # Arguments: # type type of expansion (path / proc / variable) # # Returns: # number of matches found # proc expand {args} { array set opts { -type any -widget {} } set args [get_opts opts $args {-type 1 -widget 1} {-widget widget}] if {[string match {} $opts(-widget)] && [llength $args]!=1} { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-type type?\ ?-widget widget || str?" } set prefix [namespace current]::expand_ if {[string match {} [set arg [info commands $prefix$opts(-type)]]]} { set arg [info commands $prefix$opts(-type)*] } set result {} set code ok if 0 { set exp "\[^\\]\[ \t\n\r\[\{\"\$]" set tmp [$w search -backwards -regexp $exp insert-1c limit-1c] if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit} if {[$w compare $tmp >= insert]} return set str [$w get $tmp insert] } switch [llength $arg] { 1 { set code [catch {uplevel $arg $args} result] } 0 { set arg [info commands $prefix*] regsub -all $prefix $arg {} arg return -code error "unknown [lindex [info level 0] 0] type\ \"$opts(-type)\", must be one of: [join [lsort $arg] {, }]" } default { regsub -all $prefix $arg {} arg return -code error "ambiguous type \"$opts(-type)\",\ could be one of: [join [lsort $arg] {, }]" } } if 0 { set len [llength $res] if {$len} { $w delete $tmp insert $w insert $tmp [lindex $res 0] if {$len > 1} { upvar \#0 [namespace current]::[winfo parent $w] data if {$data(-showmultiple) && \ ![string compare [lindex $res 0] $str]} { puts stdout [lsort [lreplace $res 0 0]] } } } else { bell } return [incr len -1] } return -code $code [string trimright $result \n] } # expand_pathname -- # # expand a file pathname based on $str # This is based on UNIX file name conventions # # Arguments: # str partial file pathname to expand # Results: # Returns list containing longest unique match followed by all the # possible further matches # proc expand_pathname {str} { #reval pwd, cd, glob and final cd set pwd [pwd] if {[catch {cd [file dirname $str]} err]} { return -code error $err } if {[catch {glob [file tail $str]*} m]} { set match {} } else { if {[llength $m] > 1} { global tcl_platform if {[string match windows $tcl_platform(platform)] \ && [string compare "Windows NT" $tcl_platform(os)]} { ## Windows is screwy because it can be case insensitive set tmp [best_match [string tolower [lsort $m]] \ [string tolower [file tail $str]]] } else { set tmp [best_match [lsort $m] [file tail $str]] } if {[string match ?*/* $str]} { set tmp [file dirname $str]/$tmp } elseif {[string match /* $str]} { set tmp /$tmp } regsub -all { } $tmp {\\ } tmp set match [linsert $m 0 $tmp] } else { ## This may look goofy, but it handles spaces in path names eval append match $m if {[file isdir $match]} {append match /} if {[string match ?*/* $str]} { set match [file dirname $str]/$match } elseif {[string match /* $str]} { set match /$match } regsub -all { } $match {\\ } match ## Why is this one needed and the ones below aren't!! set match [list $match] } } cd $pwd return $match } # expand_proc -- # ## ExpandProcname - expand a tcl proc name based on $str # ARGS: str - partial proc name to expand # Calls: best_match # Returns: list containing longest unique match followed by all the # possible further matches # # Arguments: # args comments # Results: # Returns ... # proc expand_proc {str} { #reval info set match [uplevel info commands [list $str]*] if {[llength $match] > 1} { regsub -all { } [best_match $match $str] {\\ } str set match [linsert $match 0 $str] } else { regsub -all { } $match {\\ } match } return $match } # expand_variable -- # ## ExpandVariable - expand a tcl variable name based on $str # ARGS: str - partial tcl var name to expand # Calls: best_match # Returns: list containing longest unique match followed by all the # possible further matches # # Arguments: # args comments # Results: # Returns ... # proc expand_variable {str} { #reval "array names", "info vars" if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { ## Looks like they're trying to expand an array. set match [array names $ary $str*] if {[llength $match] > 1} { set vars $ary\([best_match $match $str] foreach var $match {lappend vars $ary\($var\)} return $vars } else {set match $ary\($match\)} ## Space transformation avoided for array names. } else { set match [info vars $str*] if {[llength $match] > 1} { regsub -all { } [best_match $match $str] {\\ } str set match [linsert $match 0 $str] } else { regsub -all { } $match {\\ } match } } return $match } }; # end of namespace ::Utility::expand |
Added library/util-find.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The following operands are supported: path a path name of a starting point in the directory hierarchy. The first argument that starts with a -, or is a ! or a (, and all subsequent arguments will be interpreted as an expression made up of the following primaries and operators. In the descriptions, wherever n is used as a primary argu- ment, it will be interpreted as a decimal integer optionally preceded by a plus (+) or minus (-) sign, as follows: +n more than n n exactly n -n less than n. Valid expressions are: -atime n True if the file was accessed n days ago. The access time of directories in path is changed by find itself. -ctime n True if the file's status was changed n days ago. -eval command True if the executed command returns a zero value as exit status. The end of command must be punctuated by an escaped semicolon. A command argument {} is replaced by the current path name. -follow Always True; causes symbolic links to be fol- lowed. When following symbolic links, find keeps track of the directories visited so that it can detect infinite loops; for exam- ple, such a loop would occur if a symbolic link pointed to an ancestor. This expression should not be used with the -type l expres- sion. -group gname True if the file belongs to the group gname. If gname is numeric and does not appear in the /etc/group file, it is taken as a group ID. -inum n True if the file has inode number n. -links n True if the file has n links. -ls Always true; prints current path name together with its associated statistics. These include (respectively): inode number size in kilobytes (1024 bytes) protection mode number of hard links user group size in bytes modification time. If the file is a special file the size field will instead contain the major and minor device numbers. If the file is a symbolic link the pathname of the linked-to file is printed preceded by `->'. The format is identical to that of ls -gilds (see ls(1)). Note: Formatting is done internally, without executing the ls program. -mtime n True if the file's data was modified n days ago. -name pattern True if pattern matches the current file name. Normal shell file name generation characters (see sh(1)) may be used. A backslash (\) is used as an escape character within the pattern. The pattern should be escaped or quoted when find is invoked from the shell. -newer file True if the current file has been modified more recently than the argument file. -perm [-]mode The mode argument is used to represent file mode bits. It will be identical in format to the <symbolicmode> operand described in chmod(1), and will be interpreted as follows. To start, a template will be assumed with all file mode bits cleared. An op symbol of: + will set the appropriate mode bits in the template; - will clear the appropriate bits; = will set the appropriate mode bits, without regard to the contents of pro- cess' file mode creation mask. The op symbol of - cannot be the first char- acter of mode; this avoids ambiguity with the optional leading hyphen. Since the initial mode is all bits off, there are not any sym- bolic modes that need to use - as the first character. If the hyphen is omitted, the primary will evaluate as true when the file permission bits exactly match the value of the resulting template. Otherwise, if mode is prefixed by a hyphen, the primary will evaluate as true if at least all the bits in the resulting template are set in the file permission bits. -perm [-]onum True if the file permission flags exactly match the octal number onum (see chmod(1)). If onum is prefixed by a minus sign (-), only the bits that are set in onum are compared with the file permission flags, and the expression evaluates true if they match. -print Always true; causes the current path name to be printed. -prune Always yields true. Do not examine any directories or files in the directory struc- ture below the pattern just matched. See the examples, below. -puts -size n[c] True if the file is n blocks long (512 bytes per block). If n is followed by a c, the size is in bytes. -type c True if the type of the file is c, where c is b, c, d, l, p, or f for block special file, character special file, directory, symbolic link, fifo (named pipe), or plain file, respectively. -user uname True if the file belongs to the user uname. If uname is numeric and does not appear as a login name in the /etc/passwd file, it is taken as a user ID. proc find {dir args} { } proc rglob {{pat *}} { set result [glob -nocomplain $pat] foreach f $result { if {[file isdirectory $f]} { lappend result [rglob [file join $f $pat]] } } return $result } |
Added library/util-list.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 | * AT = AsserTcl /''done''/ * EL = ExtraL /''done''/ * JS = jstools /''done''/ * JT = jultaf /''done''/ * PB = Pool_Base /''done''/ * TclX = TclX /''done''/ ---- (EL) oneof element list (TclX) lcontain list element Determine if the element is a list element of list. If the element is contained in the list, 1 is returned, otherwise, 0 is returned. (EL) lunion list list ... returns the union of the lists (TclX) union lista listb Procedure to return the logical union of the two specified lists. Any duplicate elements are removed. (EL) lcommon list list ... returns the common elements of the lists. (TclX) intersect lista listb Procedure to return the logical intersection of two lists. The returned list will be sorted. (EL) leor list1 list2 returns the elements that are not shared between both lists (TclX) intersect3 lista listb Procedure to intersects two lists, returning a list containing three lists: The first list returned is everything in lista that wasn't in listb. The second list contains the intersection of the two lists, and the third list contains all the elements that were in listb but weren't in lista. The returned lists will be sorted. (TclX) lempty list Determine if the specified list is empty. If empty, 1 is returned, otherwise, 0 is returned. This command is an alternative to comparing a list to an empty string, however it checks for a string of all whitespaces, which is an empty list. ---- (JT) Juf::Sequence::assign LIST ?NAME ...? Sets value of the variables specified by the NAME arguments to that of the existing elements of LIST. Returns remaining list elements. If the number of variables exceeds the list length, the remaining variables will be removed. (PB) ::pool::list::assign varList list By Brent Welch. Assigns a set of variables from a list of values. If there are more values than variables, they are ignored. If there are fewer values than variables, the variables get the empty string. (TclX) lassign list var ?var...? Assign successive elements of a list to specified variables. If there are more variable names than fields, the remaining variables are set to the empty string. If there are more elements than variables, a list of the unassigned elements is returned. For example, lassign {dave 100 200 {Dave Foo}} name uid gid longName Assigns name to ``dave'', uid to ``100'', gid to ``200'', and longName to ``Dave Foo''. ---- (EL) lfind mode list pattern (TclX) lmatch ?mode? list pattern Search the elements of list, returning a list of all elements matching pattern. If none match, an empty list is returned. The mode argument indicates how the elements of the list are to be matched against pattern and it must have one of the following values: -exact The list element must contain exactly the same string as pattern. -glob Pattern is a glob-style pattern which is matched against each list element using the same rules as the string match command. -regexp Pattern is treated as a regular expression and matched against each list element using the same rules as the regexp command. If mode is omitted then it defaults to -glob. (JT) Juf::Sequence::match PATTERN LIST Returns a new list with all elements of LIST matching PATTERN as with string match. == glob '''!''' (PB) ::pool::list::match list pattern All words not contained in list pattern are removed from list. In set-notation: result = intersect (list, pattern). This is not completely true, duplicate entries in 'list' remain in the result, given that they appear at all. (PB) ::pool::list::filter list pattern All words contained in the list pattern are removed from list. In set-notation: result = list - pattern. Returns the set difference of list and pattern. '''Negative match'''. ---- (EL) lremdup ?-sorted? list ?var? returns a list in which all duplactes are removed. with the -sorted option the command will usually be a lot faster, but $list must be sorted with lsort; The optional $var gives the name of a variable in which the removed items will be stored. (TclX) lrmdups list Procedure to remove duplicate elements from a list. The returned list will be sorted. (PB) ::pool::list::uniq list Removes duplicate entries from list. Returns the modified list. ---- (EL) laddnew listName ?item? ... adds the items to the list if not already there (JT) Juf::Sequence::append ?OPTION ...? NAME ?VALUE ...? Works like the Tcl builtin lappend, but considers these options: -nonempty Append only non-empty values. -- Marks the end of the options. The argument following this one will be treated as NAME even if it starts with a -. (TclX) lvarcat var string ?string...? This command treats each string argument as a list and concatenates them to the end of the contents of var, forming a a single list. The list is stored back into var and also returned as the result. if var does not exist, it is created. ---- (PB) ::pool::list::pop listVar Removes the last element of the list contained in variable listVar. Returns the last element of the list, or {} in case of an empty list. (JT) Juf::Sequence::pop NAME ?COUNT? Removes COUNT element from the end of the list stored in the variable NAME and returns the last element removed. COUNT defaults to 1. (EL) lpop listName ?pos? returns the last element from a list, thereby removing it from the list. If pos is given it will return the pos element of the list. (JT) Juf::Sequence::shift NAME ?COUNT? Removes COUNT element from the list stored in the variable NAME and returns the last element removed. COUNT defaults to 1. (EL) lshift listName returns the first element from a list, thereby removing it from the list. (PB) ::pool::list::shift listVar The list stored in the variable listVar is shifted down by one. Returns the first element of the list stored in listVar, or {} for an empty list. The latter is not a sure signal, as the list may contain empty elements. (PB) ::pool::list::remove listVar position Removes the item at position from the list stored in variable listVar. (PB) ::pool::list::exchange listVar position newItem Removes the item at position from the list stored in variable listVar and inserts newItem in its place. Returns the changed list. (TclX) lvarpop var ?indexExpr? ?string? The lvarpop command pops (deletes) the element indexed by the expression indexExpr from the list contained in the variable var. If index is omitted, then 0 is assumed. If string, is specified, then the deleted element is replaced by string. The replaced or deleted element is returned. Thus ``lvarpop argv 0'' returns the first element of argv, setting argv to contain the remainder of the string. If the expression indexExpr starts with the string end, then end is replaced with the index of the last element in the list. If the expression starts with len, then len is replaced with the length of the list. ---- (PB) ::pool::list::push listvar args The same as 'lappend', provided for symmetry only. (EL) lpush listName ?item? ?position? opposite of lpop. (EL) lunshift listName ?item? opposite of lshift: prepends ?item? to the list. (PB) ::pool::list::prepend listVar newElement (PB) ::pool::list::unshift listVar newElement The list stored in the variable listVar is shifted up by one. newElement is inserted afterward into the now open head position. (TclX) lvarpush var string ?indexExpr? The lvarpush command pushes (inserts) string as an element in the list contained in the variable var. The element is inserted before position indexExpr in the list. If index is omitted, then 0 is assumed. If var does not exists, it is created. If the expression indexExpr starts with the string end, then end is replaced with the index of the last element in the list. If the expression starts with len, then len is replaced with the length of the list. Note the a value of end means insert the string before the last element. ---- (PB) ::pool::list::head list Returns the first element of list. (PB) ::pool::list::last list Returns the last element of list. (PB) ::pool::list::prev list Returns everything before the last element of list. (PB) ::pool::list::tail list Returns everything behind the first element of list. ---- (EL) remove listName ?item? ... removes the items from the list (PB) ::pool::list::delete listVar value By Brent Welch. Deletes an item from the list stored in listVar, by value. Returns 1 if the item was present, else 0. ---- (EL) lsub list ?-exclude? index_list create a sublist from a set of indices. When -exclude is specified, the elements of which the indexes are not in the list will be given. eg.: % lsub {Ape Ball Field {Antwerp city} Egg} {0 3} Ape {Antwerp city} % lsub {Ape Ball Field {Antwerp city} Egg} -exclude {0 3} Ball Field Egg (PB) ::pool::list::select list indices Idea from a thread in c.l.t. General permutation / selection of list elements. Takes the elements of list whose indices were given to the command and returns a new list containing them, in the specified order. ---- (EL) lcor gives the positions of the elements in list in the reference list. If an element is not found in the reference list, it returns -1. Elements are matched only once. eg.: % lcor {a b c d e f} {d b} 3 1 % lcor {a b c d e f} {b d d} 1 3 -1 (EL) llremove ?-sorted? list1 list2 ?var? returns a list with all items in list1 that are not in list2. with the -sorted option the command will usually be a lot faster, but both given lists must be sorted with lsort; The optional $var give the name of a variable in which the removed items will be stored. (EL) lmerge ?list1? ?list2? ??spacing?? merges two lists into one eg.: % lmerge {a b c} {1 2 3} a 1 b 2 c 3 % lmerge {a b c d} {1 2} 2 a b 1 c d 2 (EL) lunmerge ?list? ?spacing? ?var? unmerges items from a list to the result; the remaining items are stored in the given variable ?var? eg.: % lunmerge {a 1 b 2 c 3} a b c % lunmerge {a b 1 c d 2} 2 var a b c d % set var 1 2 (EL) lset listName ?item? ?indexlist? sets all elements of the list at the given indices to value ?item? (EL) larrayset array varlist valuelist sets the values of valuelist to the respective elements in varlist for the given array. (EL) lregsub ?switches? exp list subSpec does a regsub for each element in the list, and returns the resulting list. eg.: % lregsub {c$} {afdsg asdc sfgh {dfgh shgfc} dfhg} {!} afdsg asd! sfgh {dfgh shgf!} dfhg % lregsub {^([^.]+)\.([^.]+)$} {start.sh help.ps h.sh} {\2 \1} {sh start} {ps help} {sh h} (PB) ::pool::list::reverse list Returns the reversed list. (PB) ::pool::list::projection list column Treats list as list of lists and extracts the column'th element of each list item. If list is seen as matrix, then the procedure returns the data of the specified column. (PB) ::pool::list::apply cmd list Applies cmd to all entries of list and concatenates the individual results into a single list. The cmd must accept exactly one argument, which will be the current element. (PB) ::pool::list::lengthOfLongestEntry (list) Determines the length of the longest entry contained in the list. (AT) lall item_list list expr List universal quantifier: evaluates expr for all items or item sequences, and returns 1 if the expresson is true over the whole list, and 0 otherwise (AT) lexit item_list list expr List existential quantifier: evaluates expr for all items or item sequences, and returns 1 if the expresson is true for any item in the list, and 0 otherwise (JS) j:longest_match find the longest common initial string in a list |
Added library/util-mail.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # util-mail.tcl -- # # This file implements package ::Utility::mail, which ... # # Copyright (c) 1998-1999 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #package require NAME VERSION package provide ::Utility::mail 1.0 namespace eval ::Utility::mail {; namespace export -clear * ;proc sendmail {args} { # cheap getopts, no error handling array set opts [list -to {} -from {} -body {} \ -fields {} -subject {} -attach {}] foreach {key val} $args { if {[info exists opts($key)]} { set opts($key) $val } } if {[string match {} $opts(-to)] || [string match {} $opts(-from)]} { cgi_die "Error: -to and -from must be specified to sendmail\ \n[info level 0]" } if {[string length $opts(-attach)] && \ [catch {open $opts(-attach) r} atfid]} { cgi_die "Error: couldn't find file to attach \"$opts(-attach)\"" } set mailprog "/usr/lib/sendmail -t -oi" if {[catch {open "|$mailprog" r+} mailfid]} { cgi_die "Error: couldn't execute \"$mailprog\"" $mailfid } puts $mailfid "From: $opts(-from)" puts $mailfid "To: $opts(-to)" puts $mailfid "Subject: AutoSSI $opts(-subject)" if {[string length $opts(-fields)]} { puts $mailfid $opts(-fields) } if {[string length $opts(-attach)] && [info exists atfid]} { set bound "----NEXT_PART_[clock seconds].[pid]" puts $mailfid "Content-Type: multipart/mixed;\n\tboundary=\"$bound\"" append pre "This message is in MIME format. " \ "Since your mail reader does not understand this format," \ "\nsome or all of this message may not be legible.\n\n" append body "Content-Type: text/plain;\n" \ "\tcharset=\"iso-8859-1\"\n" \ "Content-Transfer-Encoding: quoted-printable\n\n" set data [read $atfid] close $atfid if {[info tclversion]<8.1 || [string first \0 $data]>=0} { append attach "Content-Type: application/octet-stream;\n" \ "\tname=\"$opts(-attach)\"\n" \ "Content-Disposition: attachment;\n" \ "\tfilename=\"$opts(-attach)\"\n\n" } else { append attach "Content-Type: text-plain;\n" \ "\tcharset=\"iso-8859-1\"\n" \ "\tname=\"$opts(-attach)\"\n" \ "Content-Transfer-Encoding: quoted-printable\n" \ "Content-Disposition: attachment;\n" \ "\tfilename=\"$opts(-attach)\"\n\n" } set len [string length "$pre--$bound\n$body$opts(-body)\n--$bound\n$attach$data\n--$bound--"] puts $mailfid "Content-Length: $len\n" puts $mailfid "$pre--$bound\n$body$opts(-body)\n--$bound\n$attach$data\n--$bound--" } else { puts $mailfid "\n$opts(-body)" } if {[catch {close $mailfid} err]} { puts stderr $err } } variable SMTP array set SMTP [list socket 25] proc smtpmail {host to from subject text} { # Send a Mail with the following command : # send_SMTP_mail <SMTP_HOST> <Recipient> <From> <Subject> <Text> variable SMTP set socket [socket $host $SMTP(socket)] fconfigure $socket -buffering line puts $socket "MAIL From:<$from>" gets $socket foreach addr $to { puts $socket "RCPT To:<$addr>" } gets $socket puts $socket DATA gets $socket puts $socket "From: <$from>\nTo: <$recipients>Subject: $subject\n" foreach line [split $text \n] { puts $socket [join $line] } puts $socket .\nQUIT gets $socket close $socket } }; # end namespace |
Added library/util-number.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | # util-number.tcl -- # # This file implements package ::Utility::number, which ... # # Copyright (c) 1997-1999 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #package require NAME VERSION package provide ::Utility::number 1.0 namespace eval ::Utility::number {; namespace export -clear * # largest_int -- # Finds the largest recognized int in Tcl for the platform # Arguments: # none # Results: # Returns the largest allowed value for an int (for exprs and stuff) # ;proc largest_int {} { set int 1 set exp 7; # assume we get at least 8 bits while {$int > 0} { set int [expr {1 << [incr exp]}] } expr {$int-1} } # int_bits -- # Finds the number of bits in an int # Arguments: # none # Results: # Returns the numbers of bits in an int # ;proc int_bits {} { set int 1 set exp 7; # assume we get at least 8 bits while {$int > 0} { set int [expr {1 << [incr exp]}] } # pop up one more, since we start at 0 incr exp } # get_square_size -- # gets the minimum square size for an input # Arguments: # num number # Returns: # returns smallest square size that would fit number # ;proc get_square_size num { set i 1 while {($i*$i) < $num} { incr i } return $i } # dec2roman -- # converts a decimal to roman numeral # Arguments: # x number in decimal format # Returns: # roman numeral # ;proc dec2roman {x} { set result "" foreach [list val roman] [list 1000 M 900 CM 500 D 400 CD 100 C 90 XC \ 50 L 40 XL 10 X 9 IX 5 V 4 IV 1 I] { while {$x >= $val} { append result $roman incr x -$val } } return $result } # bin2hex -- # converts binary to hex number # Arguments: # bin number in binary format # Returns: # hexadecimal number # ;proc bin2hex bin { ## No sanity checking is done array set t { 0000 0 0001 1 0010 2 0011 3 0100 4 0101 5 0110 6 0111 7 1000 8 1001 9 1010 a 1011 b 1100 c 1101 d 1110 e 1111 f } set diff [expr {4-[string length $bin]%4}] if {$diff != 4} { set bin [format %0${diff}d$bin 0] } regsub -all .... $bin {$t(&)} hex return [subst $hex] } # hex2bin -- # converts hex number to bin # Arguments: # hex number in hex format # Returns: # binary number (in chars, not binary format) # ;proc hex2bin hex { set t [list 0 0000 1 0001 2 0010 3 0011 4 0100 \ 5 0101 6 0110 7 0111 8 1000 9 1001 \ a 1010 b 1011 c 1100 d 1101 e 1110 f 1111] regsub {^0[xX]} $hex {} hex return [string map -nocase $t $hex] } # commify -- # puts commas into a decimal number # Arguments: # num number in acceptable decimal format # sep separator char (defaults to English format ",") # Returns: # number with commas in the appropriate place # proc commify {num {sep ,}} { while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1$sep\\2" num]} {} return $num } # isluhn -- # Checks whether a given number is a valid credit card number # Mod 10 Rules # The rules for a Mod 10 check: # The credit card number must be between 13 and 16 digits. # The credit card number must start with: # 4 for Visa Cards # 37 for American Express Cards # 5 for MasterCards # 6 for Discover Cards # If the credit card number is less then 16 digits add zeros to # the beginning to make it 16 digits. # Multiply each digit of the credit card number by the # corresponding digit of the mask, and sum the results together. # Once all the results are summed divide by 10, if there is no # remainder then the credit card number is valid. # For a card with an even number of digits, double every odd numbered digit # and substract 9 if the product is greater than 9. Add up all the even # digits as well as the doubled odd digits, and the result must be a # multiple of 10 or it's not a valid card. If a card has an odd number of # digits, perform the same addition, doubling the even numbered digits # instead... # Arguments: # num card num to check # Results: # Returns 0/1 # proc isluhn {cardnum} { regsub -all {[^0-9]} $cardnum {} cardnum #set cardnum [format %.16d $cardnum] set len [string length $cardnum] if {$len < 13 || $len > 16} { return 0 } set i -1 set double [expr {!($len%2)}] set chksum 0 while {[incr i]<$len} { set c [string index $cardnum $i] if {$double} {if {[incr c $c] >= 10} {incr c -9}} incr chksum $c set double [expr {!$double}] } return [expr {($chksum%10)==0}] } variable symbols 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ variable baserng 0123456789abcdefghijklmnopqrstuvwxyz variable baseary array set baseary { 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 a 10 b 11 c 12 d 13 e 14 f 15 g 16 h 17 i 18 j 19 10 a 11 b 12 c 13 d 14 e 15 f 16 g 17 h 18 i 19 j k 20 l 21 m 22 n 23 o 24 p 25 q 26 r 27 s 28 t 29 20 k 21 l 22 m 23 n 24 o 25 p 26 q 27 r 28 s 29 t u 30 v 31 w 32 x 33 y 34 z 35 30 u 31 v 32 w 33 x 34 y 35 z } proc base2base {num srcbase destbase} { return [dec2base [base2dec $num $srcbase] $destbase] } proc dec2base {num base} { # convert a decimal num to any base (2..36) # supports fractions # this actually accepts any valid Tcl int variable baserng variable baseary if {$base < 2 || $base > 36} { return -code error "base must be between 2 and 36" } set rng {^([0-9]+)(.[0-9]+)?$} if {![regexp $rng $num junk int frac]} { return -code error "invalid decimal number \"$num\"" } if {int($int) < $base} { # use the int() above to ensure it is numeric set value $baseary($int) } elseif {$base == 8} { # format will be faster set value [format %o $int] } elseif {$base == 16} { # format will be faster set value [format %x $int] } else { set rad 0 set val 1 while {$int > $val} { set val [expr {pow($base,[incr rad])}] } set result "" while {$int > 0} { set pow [expr {int(pow($base,$rad))}] set red [expr {int($int/$pow)}] set int [expr {$int-($pow*$red)}] append result $baseary($red) incr rad -1 } incr rad while {$rad} { append result 0 incr rad -1 } set value [string trimleft $result 0] } if {[string compare {} $frac] && ($frac != 0.0)} { set rad -1 set rest "" # This is limited to a certain granularity while {$frac > 1.0e-12} { set pow [expr {(pow($base,$rad))}] set red [expr {int($frac/$pow)}] set frac [expr {$frac-($pow*$red)}] append rest $baseary($red) incr rad -1 } return $value.$rest } return $value } proc base2dec {num base} { # convert any base number (2..36) to decimal # supports fractions variable baserng variable baseary if {$base < 2 || $base > 36} { return -code error "base must be between 2 and 36" } set rng [string range $baserng 0 [expr {$base-1}]] if {![regexp "^(\[$rng\]+).?(\[$rng\]+)?\$" \ [string tolower $num] junk int frac]} { return -code error "number may only contain chars \"\[$rng\]\"" } if {$base == 16} { # format will be faster set value [format %d 0x$int] } elseif {$base == 8} { # format will be faster set value [format %d 0$int] } else { set rad [string length $int] set value 0 foreach c [split $int {}] { incr rad -1 set value [expr {$value+(int(pow($base,$rad))*$baseary($c))}] } } if {[string compare {} [string trimright $frac 0]]} { set rad 0 set rest 0.0 foreach c [split $frac {}] { incr rad set rest [expr {$rest+($baseary($c)/pow($base,$rad))}] } return [expr {$value+$rest}] } return $value } proc add_baseX {numA numB} { # add two numbers in any base that can be expressed as a string of # unique symbols # # John Ellson <[email protected]> variable symbols set base [string length $symbols] set idxA [string length $numA] set idxB [string length $numB] set carry 0 set result "" while {$idxA || $idxB || $carry} { if {$idxA} { set digA [string index $numA [incr idxA -1]] set decA [string first $digA $symbols] if {$decA < 0} { puts stderr "invalid digit \"$digA\"" return -1 } } else { set decA 0 } if {$idxB} { set digB [string index $numB [incr idxB -1]] set decB [string first $digB $symbols] if {$decB < 0} { puts stderr "invalid digit \"$digB\"" return -1 } } else { set decB 0 } set sumdec [expr {$decA + $decB + $carry}] if {$sumdec >= $base} { set carry 1 incr sumdec -$base } else { set carry 0 } set result [string index $symbols $sumdec]$result } return $result } } |
Added library/util-string.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 | # util-string.tcl -- # # This file implements package ::Utility::string, which ... # # Copyright (c) 1997-1999 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # #package require NAME VERSION package provide ::Utility::string 1.0; # SET VERSION namespace eval ::Utility::string {; namespace export -clear * # string_ord -- # ordinals of a string, returns list comprised of chars ordinalized # ctype ord character # Convert a character into its decimal numeric value # ctype char number # Converts the numeric value, string, to an ASCII character # split - split by multi-char string # translit inrange outrange string (mesh with ord AND char) # Translate characters in string, changing characters # occurring in inrange to the corresponding character in # outrange. Inrange and outrange may be list of characters # or a range in the form `A-M'. # string_reverse -- # reverses input string # Arguments: # s input string to reverse # Returns: # string with chars reversed # ;proc string_reverse s { if {[set i [string len $s]]} { while {$i} {append r [string index $s [incr i -1]]} return $r } } proc reverse s { set t "" set len [string len $s] for {} {$len >= 0} {} { append t [string index $s [incr len -1]] } return $t } # obfuscate -- # If I describe it, it ruins it... # Arguments: # s input string # Returns: # output # ;proc obfuscate s { if {[set len [string len $s]]} { set i -1 while {[incr i]<$len} { set c [string index $s $i] if {[regexp "\[\]\\\[ \{\}\t\n\"\]" $c]} { append r $c } else { scan $c %c c append r \\[format %0.3o $c] } } return $r } } # untabify -- # removes tabs from a string, replacing with appropriate number of spaces # There should be no newlines in the string (do a split $str \n and pass # each line to this proc). # Arguments: # str input string # tablen tab length, defaults to 8 # Returns: # string sans tabs # ;proc untabify {str {tablen 8}} { set out {} while {[set i [string first "\t" $str]] != -1} { set j [expr {$tablen - ($i % $tablen)}] append out [string range $str 0 [incr i -1]][format %*s $j { }] set str [string range $str [incr i 2] end] } return $out$str } # tabify -- # converts excess spaces to tab chars # Arguments: # str input string # tablen tab length, defaults to 8 # Returns: # string with tabs replacing excess space where appropriate # ;proc tabify {str {tablen 8}} { ## We must first untabify so that \t is not interpreted to be one char set str [untabify $str] set out {} while {[set i [string first { } $str]] != -1} { ## Align i to the upper tablen boundary set i [expr {$i+$tablen-($i%$tablen)-1}] set s [string range $str 0 $i] if {[string match {* } $s]} { append out [string trimright $s { }]\t } else { append out $s } set str [string range $str [incr i] end] } return $out$str } # wrap_lines -- # wraps text to a specific max line length # Arguments: # txt input text # len desired max line length+1, defaults to 75 # P paragraph boundary chars, defaults to \n\n # P2 substitute for $P while processing, defaults to \254 # this char must not be in the input text # Returns: # text with lines no longer than $len, except where a single word # is longer than $len chars. Does not preserve paragraph boundaries. # ;proc wrap_lines "txt {len 75} {P \n\n} {P2 \254}" { # @author Jeffrey Hobbs <[email protected]> # # @c Wraps the given <a text> into multiple lines not # @c exceeding <a len> characters each. Lines shorter # @c than <a len> characters might get filled up. # # @a text: The string to operate on. # @a len: The maximum allowed length of a single line. # @a P: Paragraph boundary chars, defaults to \n\n # @a P2: Substitute for $P while processing, defaults to \254 # this char must not be in the input text # # @r Basically <a text>, but with changed newlines to # @r restrict the length of individual lines to at most # @r <a len> characters. # @n This procedure is not checked by the testsuite. # @i wrap, word wrap # Convert all instances of paragraph separator $P into $P2 # Convert all newlines into spaces and initialize the result regsub -all $P $txt $P2 txt regsub -all "\n" $txt { } txt incr len -1 set out {} # As long as the string is longer than the intended length of # lines in the result: while {[string len $txt]>$len} { # - Find position of last space in the part of the text # which could a line in the result. # - We jump out of the loop if there is none and the whole # text does not contain spaces anymore. In the latter case # the rest of the text is one word longer than an intended # line, we cannot avoid the longer line. set i [string last { } [string range $txt 0 $len]] if {$i == -1 && [set i [string first { } $txt]] == -1} { break } # Get the just fitting part of the text, remove any heading # and trailing spaces, then append it to the result string, # don't close it with a newline! append out [string trim [string range $txt 0 [incr i -1]]]\n # Shorten the text by the length of the processed part and # the space used to split it, then iterate. set txt [string range $txt [incr i 2] end] } regsub -all $P2 $out$txt $P txt return $txt } }; # end of namespace ::Utility::string |
Added library/util-tk.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | # util-tk.tcl -- # # This file implements package ::Utility::tk, which ... # # Copyright (c) 1997-8 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tk package require ::Utility package provide ::Utility::tk 1.0 namespace eval ::Utility::tk {; proc highlight args {} proc highlight_dialog args {} namespace export -clear * ## PROBLEM HERE ## ## Only uncomment one of the following namespace import lines ## ## This is what I theoretically need, but it causes the Abort in ## regular wish. This works for wish with TCL_MEM_DEBUG. #namespace import -force ::Utility::get_opts ::Utility::highlight ## This works, but is essentially useless in my situation #namespace import -force ::Utility::expand::* ::Utility::dump::* ## This works too, but is silly #after idle [namespace code [list namespace import -force \ ::Utility::highlight ::Utility::get_opts]] ## This causes constant Bus Error on startup with regular wish ## but the Abort with debugging wish. #namespace import -force ::Utility::* ## The abort message mentioned above is: #DeleteImportedCmd: did not find cmd in real cmd's list of import references #Abort ## If I try loading the above interactively as opposed to the tour at ## command line, I get a seg fault instead of a bus error. ## ## YOU CAN IGNORE THE REST ## # warn -- # # Simple warning alias to ease programming # # Arguments: # msg The warning message to display # Results: # Returns nothing important. # proc warn {msg} { bell tk_dialog .__warning Warning $msg warning 0 OK } ## Centers the canvas around points x & y ## ## Unoptimized, this looks like: ## set xtenth [expr .10 * [winfo width $w]] ## set ytenth [expr .10 * [winfo height $w]] ## set X [expr [winfo width $w] / 2] ## set Y [expr [winfo height $w] / 2] ## set x1 [expr round(($x-$X)/$xtenth)] ## set y1 [expr round(($y-$Y)/$ytenth)] ## $w xview scroll $x1 units ## $w yview scroll $y1 units ## proc canvas_center {w x y} { $w xview scroll [expr {round(10.0*$x/[winfo width $w]-5)}] units $w yview scroll [expr {round(10.0*$y/[winfo height $w]-5)}] units } ## "see" method alternative for canvas ## Aligns the named item as best it can in the middle of the screen ## Behavior depends on whether -scrollregion is set ## ## c - a canvas widget ## item - a canvas tagOrId proc canvas_see {c item} { set box [$c bbox $item] if {[string match {} $box]} return if {[string match {} [$c cget -scrollregion]]} { ## People really should set -scrollregion you know... foreach {x y x1 y1} $box { set x [expr {round(2.5*($x1+$x)/[winfo width $c])}] set y [expr {round(2.5*($y1+$y)/[winfo height $c])}] } $c xview moveto 0 $c yview moveto 0 $c xview scroll $x units $c yview scroll $y units } else { ## If -scrollregion is set properly, use this foreach {x y x1 y1} $box {top btm} [$c yview] {left right} [$c xview] \ {p q xmax ymax} [$c cget -scrollregion] { set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}] set ypos [expr {(($y1+$y)/2.0)/$ymax - ($btm-$top)/2.0}] } $c xview moveto $xpos $c yview moveto $ypos } } ## Set cursor of widget $w and its descendants to $cursor ## Ignores {} cursors proc cursor_set {w cursor} { variable CURSOR if {[string compare {} [set CURSOR($w) [$w cget -cursor]]]} { $w config -cursor $cursor } else { unset CURSOR($w) } foreach child [winfo children $w] { cursor_set $child $cursor } } ## Restore cursor based on CURSOR($w) for $w and its descendants ## $cursor is the default cursor (if none was cached) proc cursor_restore {w {cursor {}}} { variable CURSOR if {[info exists CURSOR($w)]} { $w config -cursor $CURSOR($w) } else { $w config -cursor $cursor } foreach child [winfo children $w] { cursor_restore $child $cursor } } # highlight -- # searches in text widget for $str and highlights it # If $str is empty, it just deletes any highlighting # This really belongs in ::Utility::tk # Arguments: # w text widget # str string to search for # -nocase specifies to be case insensitive # -regexp specifies that $str is a pattern # -tag tagId name of tag in text widget # -color color color of tag in text widget # Results: # Returns ... # ;proc highlight {w str args} { $w tag remove __highlight 1.0 end array set opts { -nocase 0 -regexp 0 -tag __highlight -color yellow } set args [::Utility::get_opts opts $args {-nocase 0 -regexp 0 -tag 1 -color 1}] if {[string match {} $str]} return set pass {} if {$opts(-nocase)} { append pass "-nocase " } if {$opts(-regexp)} { append pass "-regexp " } $w tag configure $opts(-tag) -background $opts(-color) $w mark set $opts(-tag) 1.0 while {[string compare {} [set ix [eval $w search $pass -count numc -- \ [list $str] $opts(-tag) end]]]} { $w tag add $opts(-tag) $ix ${ix}+${numc}c $w mark set $opts(-tag) ${ix}+1c } catch {$w see $opts(-tag).first} return [expr {[llength [$w tag ranges $opts(-tag)]]/2}] } # highlight_dialog -- # # creates minimal dialog interface to highlight # # Arguments: # w text widget # str optional seed string for HIGHLIGHT(string) # Results: # Returns null. # proc highlight_dialog {w {str {}}} { variable HIGHLIGHT set namesp [namespace current] set var ${namesp}::HIGHLIGHT set base $w.__highlight if {![winfo exists $base]} { toplevel $base wm withdraw $base wm title $base "Find String" pack [frame $base.f] -fill x -expand 1 label $base.f.l -text "Find:" entry $base.f.e -textvariable ${var}($w,string) pack [frame $base.opt] -fill x checkbutton $base.opt.c -text "Case Sensitive" \ -variable ${var}($w,nocase) checkbutton $base.opt.r -text "Use Regexp" -variable ${var}($w,regexp) pack $base.f.l -side left pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1 pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x pack [frame $base.btn] -fill both button $base.btn.fnd -text "Find" -width 6 button $base.btn.clr -text "Clear" -width 6 button $base.btn.dis -text "Dismiss" -width 6 eval pack [winfo children $base.btn] -padx 4 -pady 2 \ -side left -fill both focus $base.f.e bind $base.f.e <Return> [list $base.btn.fnd invoke] bind $base.f.e <Escape> [list $base.btn.dis invoke] } ## FIX namespace $base.btn.fnd config -command [namespace code \ "highlight [list $w] \[set ${var}($w,string)\] \ \[expr {\[set ${var}($w,nocase)\]?{}:{-nocase}}] \ \[expr {\[set ${var}($w,regexp)\]?{-regexp}:{}}] \ -tag __highlight -color [list yellow]"] $base.btn.clr config -command \ "[list $w] tag remove __highlight 1.0 end;\ set [list ${var}($w,string)] {}" $base.btn.dis config -command \ "[list $w] tag remove __highlight 1.0 end;\ wm withdraw [list $base]" if {[string compare {} $str]} { set ${var}($w,string) $str $base.btn.fnd invoke } if {[string compare normal [wm state $base]]} { wm deiconify $base } else { raise $base } $base.f.e select range 0 end } }; # end namespace ::Utility::Tk |
Added library/util-tools.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # util-tools.tcl -- # # This file implements package ::Utility::tools, which # contain Unix tools type commands in Tcl # # Copyright (c) 1998 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require ::Utility package provide ::Utility::tools 1.0 namespace eval ::Utility::tools {; namespace export -clear tools* namespace import -force ::Utility::* proc tools {cmd args} { set prefix [namespace current]::tools_ if {[string match {} [set arg [info commands $prefix$cmd]]]} { set arg [info commands $prefix$cmd*] } set result {} set code ok switch [llength $arg] { 1 { set code [catch {uplevel $arg $args} result] } 0 { set arg [info commands $prefix*] regsub -all $prefix $arg {} arg return -code error "unknown [lindex [info level 0] 0] type\ \"$cmd\", must be one of: [join [lsort $arg] {, }]" } default { regsub -all $prefix $arg {} arg return -code error "ambiguous type \"$cmd\",\ could be one of: [join [lsort $arg] {, }]" } } return -code $code [string trimright $result \n] } # tools_grep -- # cheap grep routine # Arguments: # exp regular expression to look for # args files to search in # Returns: # list of lines that in files that matched $exp # ;proc tools_grep {exp args} { if 0 { ## To be implemented -count -nocase -number -names -reverse -exact } if {[string match {} $args]} return set output {} foreach file [eval glob $args] { set fid [open $file] foreach line [split [read $fid] \n] { if {[regexp $exp $line]} { lappend output $line } } close $fid } return $output } # tools_touch -- # touch command in Tcl, only sets to the current time # Arguments: # args the files to touch # Results: # Returns ... # ;proc tools_touch args { foreach f $args { if {[file exists $f]} { # use lstat in case it is a link # otherwise it is the same as stat file lstat $f fstat if {$fstat(size) == 0} { set fid [open $f w+] } else { set fid [open $f a+] fconfigure $fid -translation binary # read and rewrite the last byte only seek $fid -1 end set c [read $fid 1] seek $fid -1 current puts -nonewline $fid $c } } else { set fid [open $f w+] } close $fid } } proc file_uniq {infile {outfile stdout}} { set ifid [open $infile] if {![regexp {std(out|err)} $outfile]} { set ofid [open $outfile w] } else { set ofid $outfile } while {[gets $ifid line] != -1} { if {![info exists array($line)]} { set array($line) {} puts $ofid $line } } close $ifid if {[string compare $ofid $outfile]} { close $ofid } } }; # end of namespace ::Utility::tools |
Added library/util.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 | # util.tcl -- # # This file implements package ::Utility, which ... # # Copyright (c) 1997-1999 Jeffrey Hobbs # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ## The provide goes first to prevent the recursive provide/require ## loop for subpackages package provide ::Utility 1.0 ## This assumes that all util-*.tcl files are in the same directory if {[lsearch -exact $auto_path [file dirname [info script]]]==-1} { lappend auto_path [file dirname [info script]] } namespace eval ::Utility {; ## Protos namespace export -clear * proc get_opts args {} proc get_opts2 args {} proc lremove args {} proc lrandomize args {} proc lunique args {} proc luniqueo args {} proc line_append args {} proc echo args {} proc alias args {} proc which args {} proc ls args {} proc dir args {} proc fit_format args {} proc validate args {} proc allow_null_elements args {} proc deny_null_elements args {} }; # end of ::Utility namespace prototype headers package require ::Utility::number package require ::Utility::string package require ::Utility::dump package require ::Utility::expand package require ::Utility::tools package require ::Utility::tk namespace eval ::Utility {; foreach namesp [namespace children [namespace current]] { namespace import -force ${namesp}::* } # Vitus Wagner proc xsplit [list str [list regexp "\[\t \r\n\]+"]] { set list {} while {[regexp -indices -- $regexp $str match submatch]} { lappend list [string range $str 0 [expr [lindex $match 0] -1]] if {[lindex $submatch 0]>=0} { lappend list [string range $str [lindex $submatch 0]\ [lindex $submatch 1]] } set str [string range $str [expr [lindex $match 1]+1] end] } lappend list $str return $list } # psource -- # # ADD COMMENTS HERE # # Arguments: # args comments # Results: # Returns ... # ;proc psource {file namesp {import *}} { uplevel \#0 [subst { source $file namespace import -force ${namesp}::$import } ] } # get_opts -- # # Processes -* named options, with or w/o possible associated value # and returns remaining args # # Arguments: # var variable into which option values should be stored # arglist argument list to parse # optlist list of valid options with default value # typelist optional list of option types that can be used to # validate incoming options # nocomplain whether to complain about unknown -switches (0 - default) # or not (1) # Results: # Returns unprocessed arguments. # ;proc get_opts {var arglist optlist {typelist {}} {nocomplain 0}} { upvar 1 $var data if {![llength $optlist] || ![llength $arglist]} { return $arglist } array set opts $optlist array set types $typelist set i 0 while {[llength $arglist]} { set key [lindex $arglist $i] if {[string match -- $key]} { set arglist [lreplace $arglist $i $i] break } elseif {![string match -* $key]} { break } elseif {[string match {} [set akey [array names opts $key]]]} { set akey [array names opts ${key}*] } switch [llength $akey] { 0 { ## oops, no keys matched if {$nocomplain} { incr i } else { return -code error "unknown switch '$key', must be:\ [join [array names opts] {, }]" } } 1 { ## Perfect, found just the right key if {$opts($akey)} { set val [lrange $arglist [expr {$i+1}] \ [expr {$i+$opts($akey)}]] set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]] if {[info exists types($akey)] && \ ([string compare none $types($akey)] && \ ![validate $types($akey) $val])} { return -code error "the value for \"$akey\" is not in\ proper $types($akey) format" } set data($akey) $val } else { set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]] set data($akey) 1 } } default { ## Oops, matches too many possible keys return -code error "ambiguous option \"$key\",\ must be one of: [join $akey {, }]" } } } return $arglist } # get_opts2 -- # # Process options into an array. -- short-circuits the processing # # Arguments: # var variable into which option values should be stored # arglist argument list to parse # optlist list of valid options with default value # typelist optional list of option types that can be used to # validate incoming options # Results: # Returns unprocessed arguments. # ;proc get_opts2 {var arglist optlist {typelist {}}} { upvar 1 $var data if {![llength $optlist] || ![llength $arglist]} { return $arglist } array set data $optlist array set types $typelist foreach {key val} $arglist { if {[string match -- $key]} { set arglist [lreplace $arglist 0 0] break } if {[string match {} [set akey [array names data $key]]]} { set akey [array names data ${key}*] } switch [llength $akey] { 0 { ## oops, no keys matched return -code error "unknown switch '$key', must be:\ [join [array names data] {, }]" } 1 { ## Perfect, found just the right key if {[info exists types($akey)] && \ ![validate $types($akey) $val]} { return -code error "the value for \"$akey\" is not in\ proper $types($akey) format" } set data($akey) $val } default { ## Oops, matches too many possible keys return -code error "ambiguous option \"$key\",\ must be one of: [join $akey {, }]" } } set arglist [lreplace $arglist 0 1] } return $arglist } # lintersect -- # returns list of items that exist only in all lists # Arguments: # args lists # Returns: # The list of common items, uniq'ed, order independent # proc lintersect {args} { set len [llength $args] if {$len <= 1} { return [lindex $args 0] } array set a {} foreach l [lindex $args 0] { set a($l) 1 } foreach list [lrange $args 1 end] { foreach l $list { if {[info exists a($l)]} { incr a($l) } } } set retval {} foreach l [array names a] { if {$a($l) == $len} { lappend retval $l } } return $retval } # lremove -- # remove items from a list # Arguments: # ?-all? remove all instances of said item # list list to remove items from # args items to remove # Returns: # The list with items removed # ;proc lremove {args} { set all 0 if {[string match \-a* [lindex $args 0]]} { set all 1 set args [lreplace $args 0 0] } set l [lindex $args 0] foreach i [join [lreplace $args 0 0]] { if {[set ix [lsearch -exact $l $i]] == -1} continue set l [lreplace $l $ix $ix] if {$all} { while {[set ix [lsearch -exact $l $i]] != -1} { set l [lreplace $l $ix $ix] } } } return $l } # lrandomize -- # randomizes a list # Arguments: # ls list to randomize # Returns: # returns list in with randomized items # ;proc lrandomize ls { set res {} while {[string compare $ls {}]} { set i [randrng [llength $ls]] lappend res [lindex $ls $i] set ls [lreplace $ls $i $i] } return $res } # lunique -- # order independent list unique proc, not most efficient. # Arguments: # ls list of items to make unique # Returns: # list of only unique items, order not defined # ;proc lunique ls { foreach l $ls {set ($l) x} return [array names {}] } # lunique -- # order independent list unique proc. most efficient, but requires # __LIST never be an element of the input list # Arguments: # __LIST list of items to make unique # Returns: # list of only unique items, order not defined # ;proc lunique __LIST { if {[llength $__LIST]} { foreach $__LIST $__LIST break unset __LIST return [info locals] } } # luniqueo -- # order dependent list unique proc # Arguments: # ls list of items to make unique # Returns: # list of only unique items in same order as input # ;proc luniqueo ls { set rs {} foreach l $ls { if {[info exist ($l)]} { continue } lappend rs $l set ($l) {} } return $rs } # lunion -- # order independent list union proc. most efficient, but requires # ___ never be an element of the input list # Arguments: # args lists to union # Returns: # list of only unique items among all the lists, order not defined # ;proc lunion {args} { if {[llength $args]} { foreach ___ $args { if {[llength $___]} { foreach $___ {!} {break} } } unset ___ args return [info locals] } } # luniono -- # order dependent list union proc. most efficient, but requires # ___ never be an element of the input list # Arguments: # args lists to union # Returns: # list of only unique items among all the lists, order not defined # ;proc luniono {args} { if {[llength $args]} { set rs {} foreach ls $args { foreach l $ls { if {[info exists ($l)]} {continue} lappend rs $l set ($l) {} } } return $rs } } # every -- # Cheap rescheduler # every <time> cmd; # cmd is a one arg (cmd as list) # schedules $cmd to be run every <time> 1000ths of a sec # IOW, [every 1000 "puts hello"] prints hello every sec # every cancel cmd # cancels a cmd if it was specified # every info ?pattern? # returns info about commands in pairs of "time cmd time cmd ..." # proc every {time {cmd {}}} { global EVERY if {[regexp {^[0-9]+$} $time]} { # A time was given, so schedule a command to run every $time msecs if {[string compare {} $cmd]} { set EVERY(TIME,$cmd) $time set EVERY(CMD,$cmd) [after $time [list every eval $cmd]] } else { return -code error "wrong \# args: should be \"[lindex [info level 0] 0] <number> command" } return } switch $time { eval { if {[info exists EVERY(TIME,$cmd)]} { uplevel \#0 $cmd set EVERY(CMD,$cmd) [after $EVERY(TIME,$cmd) \ [list every eval $cmd]] } } cancel { if {[string match "all" $cmd]} { foreach i [array names EVERY CMD,*] { after cancel $EVERY($i) unset EVERY($i) EVERY(TIME,[string range $i 4 end]) } } elseif {[info exists EVERY(CMD,$cmd)]} { after cancel $EVERY(CMD,$cmd) unset EVERY(CMD,$cmd) EVERY(TIME,$cmd) } } info { set result {} foreach i [array names EVERY TIME,$cmd*] { set cmd [string range $i 5 end] lappend result $EVERY($i) $cmd } return $result } default { return -code error "bad option \"$time\": must be cancel, info or a number" } } return } # best_match -- # finds the best unique match in a list of names # The extra $e in this argument allows us to limit the innermost loop a # little further. # Arguments: # l list to find best unique match in # e currently best known unique match # Returns: # longest unique match in the list # ;proc best_match {l {e {}}} { set ec [lindex $l 0] if {[llength $l]>1} { set e [string length $e]; incr e -1 set ei [string length $ec]; incr ei -1 foreach l $l { while {$ei>=$e && [string first $ec $l]} { set ec [string range $ec 0 [incr ei -1]] } } } return $ec } # randline -- # returns a random line from a file. not good on large files # because it sucks the entire file into memory. # Arguments: # file filename to get line from # Results: # Returns a line as a string # ;proc randline {file} { set fid [open $file] set data [split [read $fid] \n] close $fid return [lindex $data [randrng [llength $data]]] } # randrng -- # gets random number within input range # Arguments: # rng range to limit output to # Returns: # returns random number within range 0..$rng ;proc randrng {rng} { return [expr {int($rng * rand())}] } # line_append -- # appends a string to the end of every line of data from a file # Arguments: # file file to get data from # stuff stuff to append to each line # Returns: # file data with stuff appended to each line # ;proc line_append {file stuff} { set fid [open $file] set data [read $fid] catch {close $fid} return [join [split $data \n] $stuff\n] } # alias -- # akin to the csh alias command # Arguments: # newcmd (optional) command to bind alias to # args command and args being aliased # Returns: # If called with no args, then it dumps out all current aliases # If called with one arg, returns the alias of that arg (or {} if none) # ;proc alias {{newcmd {}} args} { if {[string match {} $newcmd]} { set res {} foreach a [interp aliases] { lappend res [list $a -> [interp alias {} $a]] } return [join $res \n] } elseif {[string match {} $args]} { interp alias {} $newcmd } else { eval interp alias [list {} $newcmd {}] $args } } # echo -- # Relaxes the one string restriction of 'puts' # Arguments: # args any number of strings to output to stdout # Returns: # Outputs all input to stdout # ;proc echo args { puts [concat $args] } # which -- # tells you where a command is found # Arguments: # cmd command name # Returns: # where command is found (internal / external / unknown) # ;proc which cmd { ## FIX - make namespace friendly set lcmd [list $cmd] if { [string compare {} [uplevel info commands $lcmd]] || ([uplevel auto_load $lcmd] && [string compare {} [uplevel info commands $lcmd]]) } { set ocmd [uplevel namespace origin $lcmd] # First check to see if it is an alias # This requires two checks because interp aliases doesn't # canonically return fully (un)qualified names set aliases [interp aliases] if {[lsearch -exact $aliases $ocmd] > -1} { set result "$cmd: aliased to \"[alias $ocmd]\"" } elseif {[lsearch -exact $aliases $cmd] > -1} { set result "$cmd: aliased to \"[alias $cmd]\"" } elseif {[string compare {} [uplevel info procs $lcmd]] || \ ([string match ?*::* $ocmd] && \ [string compare {} [namespace eval \ [namespace qualifiers $ocmd] \ [list info procs [namespace tail $ocmd]]]])} { # Here we checked if the proc that has been imported before # deciding it is a regular command set result "$cmd: procedure $ocmd" } else { set result "$cmd: command" } global auto_index if {[info exists auto_index($cmd)]} { # This tells you where the command MIGHT have come from - # not true if the command was redefined interactively or # existed before it had to be auto_loaded. This is just # provided as a hint at where it MAY have come from append result " ($auto_index($cmd))" } return $result } elseif {[string compare {} [auto_execok $cmd]]} { return [auto_execok $cmd] } else { return -code error "$cmd: command not found" } } # ls -- # mini-ls equivalent (directory lister) # Arguments: # ?-all? list hidden files as well (Unix dot files) # ?-long? list in full format "permissions size date filename" # ?-full? displays / after directories and link paths for links # args names/glob patterns of directories to list # Returns: # a directory listing # interp alias {} ::Utility::dir {} namespace inscope ::Utility ls ;proc ls {args} { array set s { -all 0 -full 0 -long 0 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx } set args [get_opts s $args [array get s -*]] set sep [string trim [file join . .] .] if {[string match {} $args]} { set args . } foreach arg $args { if {[file isdir $arg]} { set arg [string trimr $arg $sep]$sep if {$s(-all)} { lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] } else { lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] } } else { lappend out [list [file dirname $arg]$sep \ [lsort [glob -nocomplain -- $arg]]] } } if {$s(-long)} { global tcl_platform set old [clock scan {1 year ago}] switch -exact -- $tcl_platform(os) { windows { set fmt "%-5s %8d %s %s\n" } default { set fmt "%s %-8s %-8s %8d %s %s\n" } } foreach o $out { set d [lindex $o 0] if {[llength $out]>1} { append res $d:\n } foreach f [lindex $o 1] { file lstat $f st array set st [file attrib $f] set f [file tail $f] if {$s(-full)} { switch -glob $st(type) { dir* { append f $sep } link { append f " -> [file readlink $d$sep$f]" } fifo { append f | } default { if {[file exec $d$sep$f]} { append f * } } } } switch -exact -- $st(type) { file { set mode - } fifo { set mode p } default { set mode [string index $st(type) 0] } } set cfmt [expr {$st(mtime)>$old?{%b %d %H:%M}:{%b %d %Y}}] switch -exact -- $tcl_platform(os) { windows { # RHSA append mode $st(-readonly) $st(-hidden) \ $st(-system) $st(-archive) append res [format $fmt $mode $st(size) \ [clock format $st(mtime) -format $cfmt] $f] } macintosh { append mode $st(-readonly) $st(-hidden) append res [format $fmt $mode $st(-creator) \ $st(-type) $st(size) \ [clock format $st(mtime) -format $cfmt] $f] } default { ## Unix is our default platform type foreach j [split [format %o \ [expr {$st(mode)&0777}]] {}] { append mode $s($j) } append res [format $fmt $mode $st(-owner) $st(-group) \ $st(size) \ [clock format $st(mtime) -format $cfmt] $f] } } } append res \n } } else { foreach o $out { set d [lindex $o 0] if {[llength $out]>1} { append res $d:\n } set i 0 foreach f [lindex $o 1] { if {[string len [file tail $f]] > $i} { set i [string len [file tail $f]] } } set i [expr {$i+2+$s(-full)}] ## Assume we have at least 70 char cols set j [expr {70/$i}] set k 0 foreach f [lindex $o 1] { set f [file tail $f] if {$s(-full)} { switch -glob [file type $d$sep$f] { d* { append f $sep } l* { append f @ } default { if {[file exec $d$sep$f]} { append f * } } } } append res [format "%-${i}s" $f] if {[incr k]%$j == 0} {set res [string trimr $res]\n} } append res \n\n } } return [string trimr $res] } # fit_format -- # This procedure attempts to format a value into a particular format string. # # Arguments: # format - The format to fit # val - The value to be validated # # Returns: 0 or 1 (whether it fits the format or not) # # Switches: # -fill ?var? - Default values will be placed to fill format to spec # and the resulting value will be placed in variable 'var'. # It will equal {} if the match invalid # (doesn't work all that great currently) # -best ?var? - 'Fixes' value to fit format, placing best correct value # in variable 'var'. If current value is ok, the 'var' # will equal it, otherwise it removes chars from the end # until it fits the format, then adds any fixed format # chars to value. Can be slow (recursive tkFormat op). # -strict - Value must be an exact match for format (format && length) # -- - End of switches ;proc fit_format {args} { set fill {}; set strict 0; set best {}; set result 1; set name [lindex [info level 0] 0] while {[string match {-*} [lindex $args 0]]} { switch -- [string index [lindex $args 0] 1] { b { set best [lindex $args 1] set args [lreplace $args 0 1] } f { set fill [lindex $args 1] set args [lreplace $args 0 1] } s { set strict 1 set args [lreplace $args 0 0] } - { set args [lreplace $args 0 0] break } default { return -code error "bad $name option \"[lindex $args 0]\",\ must be: -best, -fill, -strict, or --" } } } if {[llength $args] != 2} { return -code error "wrong \# args: should be \"$name ?-best varname?\ ?-fill varname? ?-strict? ?--? format value\"" } set format [lindex $args 0] set val [lindex $args 1] set flen [string length $format] set slen [string length $val] if {$slen > $flen} {set result 0} if {$strict} { if {$slen != $flen} {set result 0} } if {$result} { set regform {} foreach c [split $format {}] { set special 0 if {[string match {[0AaWzZ]} $c]} { set special 1 switch $c { 0 {set fmt {[0-9]}} A {set fmt {[A-Z]}} a {set fmt {[a-z]}} W {set fmt "\[ \t\r\n\]"} z {set fmt {[A-Za-z]}} Z {set fmt {[A-Za-z0-9]}} } } else { set fmt $c } } echo $regform $format $val set result [string match $regform $val] } if [string compare $fill {}] { upvar $fill fvar if {$result} { set fvar $val[string range $format $i end] } else { set fvar {} } } if [string compare $best {}] { upvar $best bvar set bvar $val set len [string length $bvar] if {!$result} { incr len -2 set bvar [string range $bvar 0 $len] # Remove characters until it's in valid format while {$len > 0 && ![tkFormat $format $bvar]} { set bvar [string range $bvar 0 [incr len -1]] } # Add back characters that are fixed while {($len<$flen) && ![string match \ {[0AaWzZ]} [string index $format [incr len]]]} { append bvar [string index $format $len] } } else { # If it's already valid, at least we can add fixed characters while {($len<$flen) && ![string match \ {[0AaWzZ]} [string index $format $len]]} { append bvar [string index $format $len] incr len } } } return $result } # validate -- # This procedure validates particular types of numbers/formats # # Arguments: # type - The type of validation (alphabetic, alphanumeric, date, # hex, integer, numeric, real). Date is always strict. # val - The value to be validated # # Returns: 0 or 1 (whether or not it resembles the type) # # Switches: # -incomplete enable less precise (strict) pattern matching on number # useful for when the number might be half-entered # # Example use: validate real 55e-5 # validate -incomplete integer -505 # ;proc validate {args} { if {[string match [lindex $args 0]* "-incomplete"]} { set strict 0 set opt * set args [lreplace $args 0 0] } else { set strict 1 set opt + } if {[llength $args] != 2} { return -code error "wrong \# args: should be\ \"[lindex [info level 0] 0] ?-incomplete? type value\"" } else { set type [lindex $args 0] set val [lindex $args 1] } ## This is a big switch for speed reasons switch -glob -- $type { alphab* { # alphabetic return [regexp -nocase "^\[a-z\]$opt\$" $val] } alphan* { # alphanumeric return [regexp -nocase "^\[a-z0-9\]$opt\$" $val] } b* { # boolean - would be nice if it were more than 0/1 return [regexp "^\[01\]$opt\$" $val] } d* { # date - always strict return [expr {![catch {clock scan $val}]}] } h* { # hexadecimal return [regexp -nocase "^(0x)?\[0-9a-f\]$opt\$" $val] } i* { # integer return [regexp "^\[-+\]?\[0-9\]$opt\$" $val] } n* { # numeric return [regexp "^\[0-9\]$opt\$" $val] } rea* { # real return [regexp -nocase [expr {$strict ?{^[-+]?([0-9]+\.?[0-9]*|[0-9]*\.?[0-9]+)(e[-+]?[0-9]+)?$} :{^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}}] $val] } reg* { # regexp return [expr {![catch {regexp $val {}}]}] } val* { # value, any valid number type return [expr {![catch {expr {0+$val}}]}] } l* { # list return [expr {![catch {llength $val}]}] } w* { # widget return [winfo exists $val] } default { return -code error "bad [lindex [info level 0] 0] type \"$type\":\ \nmust be [join [lsort {alphabetic alphanumeric date \ hexadecimal integer numeric real value \ list boolean}] {, }]" } } return } # allow_null_elements -- # # Sets up a read trace on an array to allow reading any value # and ensure that some default exists # # Arguments: # args comments # Results: # Returns ... # ;proc allow_null_elements {array {default {}}} { uplevel 1 [list trace variable $array r [list \ [namespace code ensure_default] $default]] } ;proc ensure_default {val array idx op} { upvar $array var if {[array exists var]} { if {![info exists var($idx)]} { set var($idx) $val } } elseif {![info exists var]} { set var $val } } # deny_null_elements -- # # ADD COMMENTS HERE # # Arguments: # args comments # Results: # Returns ... # ;proc deny_null_elements {array {default {}}} { ## FIX: should use vinfo and remove any *ensure_default* read traces uplevel 1 [list trace vdelete $array r [list \ [namespace code ensure_default] $default]] } }; # end namespace ::Utility |
Added library/ventry.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 | ## self-validating entry widget ## ## Copyright 1997-8 Jeffrey Hobbs, [email protected], CADIX International ## package require Widget 2.0 package provide Ventry 2.0 ##------------------------------------------------------------------------ ## PROCEDURE ## ventry ## ## DESCRIPTION ## Implements a self-validating entry widget ## ## ARGUMENTS ## ventry <widget> ?options? ## ## OPTIONS ## ## -invalidcmd ## ## ## -validatecmd (-vcmd) ## ## ## -validate ## ## ## SUBSTITUTIONS ## ## %d the type of validation (delete, insert, ...) ## %i the index of the insert or delete ## %P the potential new string value ## %s the current value of the entry ## %S the chars to be inserted or deleted ## %v the value of -validate ## %W the widget name ## ## METHODS ## ## validate ## ## BINDINGS ## This works entirely off the textvariable, so no extra bindings ## are required. ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ##------------------------------------------------------------------------ ## EXAMPLES: ## # A number only entry widget ## ventry .v -vcmd {regexp {^[-+]?[0-9]*$} %P} -validate key -invalidcmd bell ## # An entry widget limited to 8 chars ## ventry .l -vcmd {expr {[string length %P]<=8}} -validate key ## # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc Ventry args {} proc ventry args {} widget create Ventry -type frame -base entry -components { label } -options { {-bd -borderwidth} {-borderwidth borderWidth BorderWidth 0} {-invalidcmd invalidCmd InvalidCmd bell} {-labeltext labelText LabelText {}} {-labelwidth labelWidth Width 0} {-labelanchor ALIAS label -anchor labelAnchor Anchor} {-labelfont ALIAS label -font labelFont Font} {-labelforeground ALIAS label -foreground labelForeground Foreground} {-relief relief Relief flat} {-validatecmd -vcmd} {-vcmd validateCmd ValidateCmd {}} {-validate validate Validate none} {-textvariable textVariable TextVariable {}} } namespace eval ::Widget::Ventry {; ;proc construct {w} { upvar \#0 [namespace current]::$w data set data(flags) {} grid $data(label) $data(entry) -in $w -sticky ns grid configure $data(entry) -sticky news grid columnconfig $w 1 -weight 1 grid rowconfig $w 0 -weight 1 grid remove $data(label) bind $data(entry) <FocusIn> [namespace code [list focus $w in]] bind $data(entry) <FocusOut> [namespace code [list focus $w out]] } ;proc configure {w args} { upvar \#0 [namespace current]::$w data set truth {^(1|yes|true|on)$} foreach {key val} $args { switch -- $key { -borderwidth - -relief { .$w configure $key $val } -labelanchor { $data(label) configure -anchor $val } -labelfont { $data(label) configure -font $val } -labelforeground { $data(label) configure -foreground $val } -labeltext { $data(label) configure -text $val if {[string compare {} $val]} { grid $data(label) } else { grid remove $data(label) } } -labelwidth { $data(label) configure -width $val } -validate { if {![regexp {^(focus|focusin|focusout|all|none|key)$} $val]} { return -code error "Invalid validation type \"$val\"" } } -textvariable { $data(basecmd) configure -textvariable $val } } set data($key) $val } } ;proc _insert {w index string} { upvar \#0 [namespace current]::$w data if {[regexp {^(all|key)$} $data(-validate)]} { set index [$data(basecmd) index $index] set cur [$data(basecmd) get] set new [string range $cur 0 [expr $index-1]]$string[string range $cur $index end] if {[catch {validate $w $string $new $index insert} err]} { return } } return [uplevel [list $data(basecmd) insert $index $string]] } ;proc _delete {w first {last {}}} { upvar \#0 [namespace current]::$w data if {[regexp {^(all|key)$} $data(-validate)]} { set first [$data(basecmd) index $first] if {[string match {} $last]} { set last [expr $first+1] } else { set last [$data(basecmd) index $last] } set cur [$data(basecmd) get] set new [string range $cur 0 [expr $first-1]][string range $cur $last end] if {[catch {validate $w [string range $cur $first \ [expr $last-1]] $new $first delete} err]} { return } } return [uplevel [list $data(basecmd) delete $first] $last] } ;proc _validate {w} { upvar \#0 [namespace current]::$w data set old $data(-validate) set data(-validate) all set code [catch {validate $w {} [$data(basecmd) get] \ [$data(basecmd) index insert] validate} err] set data(-validate) $old return [expr {$code?0:1}] } ;proc focus {w which} { upvar \#0 [namespace current]::$w data if {[regexp "^(all|focus($which)?)\$" $data(-validate)]} { catch {validate $w {} [$data(basecmd) get] \ [$data(basecmd) index insert] focus$which} } } ;proc validate {w str new index type} { upvar \#0 [namespace current]::$w data if {[string match {} $data(-vcmd)] || \ [string match none $data(-validate)] || \ [string match VALIDATING $data(flags)]} { return } set data(flags) VALIDATING set cmd [substitute $w $data(-vcmd) $str $new $index $type] set code [catch {uplevel \#0 $cmd} result] if {$code != 0 && $code != 2} { global errorInfo append errorInfo "\n\t(in $w validation command)" bgerror $result set code 1 } else { set val [regexp {^(1|yes|true|on)$} $result] if $val { set code 0 } else { set code 3 } set result {} } # If e->validate has become VALIDATE_NONE during the validation, # it means that a loop condition almost occured. Do not allow # this validation result to finish. if {[string match none $data(-validate)] || \ [string match VALIDATE_VAR $data(flags)]} { set code 1 } # If validate will return ERROR, then disallow further validations # Otherwise, if it didn't accept the new string (returned TCL_BREAK) # then eval the invalidCmd (if it's set) if {$code} { if {$code == 3} { ## TCL_BREAK if {[string compare {} $data(-invalidcmd)]} { set cmd [substitute $w $data(-invalidcmd) \ $str $new $index $type] if {[catch {uplevel \#0 $cmd} result]} { global errorInfo append errorInfo "\n\t(in $w validation command)" bgerror $result set code 1 set data(-validate) none } } } else { set data(-validate) none } } set data(flags) {} return -code $code $result } ;proc substitute {w cmd change newstr index type} { upvar \#0 [namespace current]::$w data set old $cmd set i [string first % $cmd] if {$i < 0} { return $old } set new [string range $cmd 0 [incr i -1]] while 1 { set c [string index $cmd [incr i 2]] switch $c { d { append new $type } i { append new $index } P { append new [list $newstr] } s { append new [list [$data(basecmd) get]] } S { append new [list $change] } v { append new $data(-validate) } W { append new [list $w] } {} { append new %; return $new } default { append new [list $c] } } set cmd [string range $cmd [incr i] end] set i [string first % $cmd] if {$i < 0} { return $new$cmd } append new [string range $cmd 0 [incr i -1]] } } }; #end namespace ::Widget::Ventry |
Added library/widget.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 | ## Barebones requirements for creating and querying megawidgets ## ## Copyright 1997-9 Jeffrey Hobbs, [email protected] ## ## Initiated: 5 June 1997 ## Last Update: 1999 ## FIX: config flag, option for setting all child widgets by default package require Tk 8 package require ::Utility package provide Widget 2.0 ##------------------------------------------------------------------------ ## PROCEDURE ## widget ## ## DESCRIPTION ## Implements and modifies megawidgets ## ## ARGUMENTS ## widget <subcommand> ?<args>? ## ## <classname> specifies a global array which is the name of a class and ## contains options database information. ## ## add classname option ?args? ## adds ... ## ## create classname ## creates the widget class $classname based on the specifications ## in the global array of the same name ## ## classes ?pattern? ## returns the classes created with this command. ## ## delete classname option ?args? ## deletes ... ## ## value classname key ## returns the value of a key from the special class variable. ## ## OPTIONS ## none ## ## RETURNS ## the namespace for the widget class (::Widget::$CLASS) ## ## NAMESPACE & STATE ## The namespace Widget is used, with public procedure "widget". ## ##------------------------------------------------------------------------ ## ## For a well-commented example for creating a megawidget using this method, ## see the ScrolledText example at the end of the file. ## ## SHORT LIST OF IMPORTANT THINGS TO KNOW: ## ## Specify the "type", "base", & "components" keys of the $CLASS global array ## ## In the $w global array that is created for each instance of a megawidget, ## the following keys are set by the "widget create $CLASS" procedure: ## "base", "basecmd", "container", "class", any option specified in the ## $CLASS array, each component will have a named key ## ## The following public methods are created for you in the namespace: ## cget ::Widget::$CLASS::_cget ## configure ::Widget::$CLASS::_configure ## destruct ::Widget::$CLASS::_destruct ## subwidget ::Widget::$CLASS::_subwidget ## The following additional submethods are required (you write them): ## construct ::Widget::$CLASS::construct ## configure ::Widget::$CLASS::configure ## You may want the following that will be called when appropriate: ## init ::Widget::$CLASS::init ## (after initial configuration) ## destruct ::Widget::$CLASS::destruct ## (called first thing when widget is being destroyed) ## ## All ::Widget::$CLASS::_* commands are considered public methods. The ## megawidget routine will match your options and methods on a unique ## substring basis. ## ## END OF SHORT LIST ## Dummy call for indexers proc widget args {} namespace eval ::Widget {; namespace export -clear widget variable CLASSES variable CONTAINERS {frame toplevel} namespace import -force ::Utility::get_opts* ;proc widget {cmd args} { ## Establish the prefix of public commands set prefix [namespace current]::_ if {[string match {} [set arg [info commands $prefix$cmd]]]} { set arg [info commands $prefix$cmd*] } switch [llength $arg] { 1 { return [uplevel $arg $args] } 0 { set arg [info commands $prefix*] regsub -all $prefix $arg {} arg return -code error "unknown [lindex [info level 0] 0] method\ \"$cmd\", must be one of: [join [lsort $arg] {, }]" } default { regsub -all $prefix $arg {} arg return -code error "ambiguous method \"$cmd\",\ could be one of: [join [lsort $arg] {, }]" } } } ;proc verify_class {CLASS} { variable CLASSES if {![info exists CLASSES($CLASS)]} { return -code error "no known class \"$CLASS\"" } return } ;proc _add {CLASS what args} { variable CLASSES verify_class $CLASS if {[string match ${what}* options]} { add_options $CLASSES($CLASS) $CLASS $args } else { return -code error "unknown type for add, must be one of:\ options, components" } } ;proc _find_class {CLASS {root .}} { if {[string match $CLASS [winfo class $root]]} { return $root } else { foreach w [winfo children $root] { set w [_find_class $CLASS $w] if {[string compare {} $w]} { return $w } } } } ;proc _delete {CLASS what args} { variable CLASSES verify_class $CLASS } ;proc _classes {{pattern "*"}} { variable CLASSES return [array names CLASSES $pattern] } ;proc _value {CLASS key} { variable CLASSES verify_class $CLASS upvar \#0 $CLASSES($CLASS)::class class if {[info exists class($key)]} { return $class($key) } else { return -code error "unknown key \"$key\" in class \"$CLASS\"" } } ## handle ## Handles the method calls for a widget. This is the command to which ## all megawidget dummy commands are redirected for interpretation. ## ;proc handle {namesp w subcmd args} { upvar \#0 ${namesp}::$w data if {[string match {} [set arg [info commands ${namesp}::_$subcmd]]]} { set arg [info commands ${namesp}::_$subcmd*] } set num [llength $arg] if {$num==1} { return [uplevel $arg [list $w] $args] } elseif {$num} { regsub -all "${namesp}::_" $arg {} arg return -code error "ambiguous method \"$subcmd\",\ could be one of: [join $arg {, }]" } elseif {[catch {uplevel [list $data(basecmd) $subcmd] $args} err]} { return -code error $err } else { return $err } } ## construct ## Constructs the megawidget instance instantiation proc based on the ## current knowledge of the megawidget. ## ;proc construct {namesp CLASS} { upvar \#0 ${namesp}::class class \ ${namesp}::components components lappend dataArrayVals [list class $CLASS] if {[string compare $class(type) $class(base)]} { ## If -type and -base don't match, we need a special setup lappend dataArrayVals "base \$w.[list [lindex $components(base) 1]]" \ "basecmd ${namesp}::\$w.[list [lindex $components(base) 1]]" \ "container ${namesp}::.\$w" ## If the base widget is not the container, then we want to rename ## its widget commands and add the CLASS and container bind tables ## to its bindtags in case certain bindings are made ## Interp alias is the optimal solution, but exposes ## a bug in Tcl7/8 when renaming aliases #interp alias {} \$base {} ::Widget::handle $namesp \$w set renamingCmd "rename \$base \$data(basecmd) ;proc ::\$base args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\" bindtags \$base \[linsert \[bindtags \$base\] 1\ [expr {[string match toplevel $class(type)]?{}:{$w}}] $CLASS\]" } else { ## -type and -base are the same, we only create for one lappend dataArrayVals "base \$w" \ "basecmd ${namesp}::\$w" \ "container ${namesp}::\$w" if {[string compare {} [lindex $components(base) 3]]} { lappend dataArrayVals "[lindex $components(base) 3] \$w" } ## When the base widget and container are the same, we have a ## straightforward renaming of commands set renamingCmd {} } set baseConstruction {} foreach name [array names components] { if {[string match base $name]} { continue } foreach {type wid opts} $components($name) break lappend dataArrayVals "[list $name] \$w.[list $wid]" lappend baseConstruction "$type \$w.[list $wid] $opts" if {[string match toplevel $type]} { lappend baseConstruction "wm withdraw \$data($name)" } } set dataArrayVals [join $dataArrayVals " \\\n\t"] ## the lsort ensure that parents are created before children set baseConstruction [join [lsort -index 1 $baseConstruction] "\n "] ## More of this proc could be configured ahead of time for increased ## construction speed. It's delicate, so handle with extreme care. ;proc ${namesp}::$CLASS {w args} [subst { variable options upvar \#0 ${namesp}::\$w data $class(type) \$w -class $CLASS [expr [string match toplevel $class(type)]?{wm withdraw \$w\n}:{}] ## Populate data array with user definable options foreach o \[array names options\] { if {\[string match -* \$options(\$o)\]} continue set data(\$o) \[option get \$w \[lindex \$options(\$o) 0\] $CLASS\] } ## Populate the data array array set data \[list $dataArrayVals\] ## Create all the base and component widgets $baseConstruction ## Allow for an initialization proc to be eval'ed ## The user must create one if {\[catch {construct \$w} err\]} { catch {_destruct \$w} return -code error \"megawidget construction error: \$err\" } set base \$data(base) rename \$w \$data(container) $renamingCmd ;proc ::\$w args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\" #interp alias {} \$w {} ::Widget::handle $namesp \$w ## Do the configuring here and eval the post initialization procedure if {(\[llength \$args\] && \ \[catch {uplevel 1 ${namesp}::_configure \$w \$args} err\]) || \ \[catch {${namesp}::init \$w} err\]} { catch { ${namesp}::_destruct \$w } return -code error \"megawidget initialization error: \$err\" } return \$w } ] } ;proc add_options {namesp CLASS optlist} { upvar \#0 ${namesp}::class class \ ${namesp}::options options \ ${namesp}::widgets widgets ## Go through the option definition, substituting for ALIAS where ## necessary and setting up the options database for this $CLASS ## There are several possible formats: ## 1. -optname -optnamealias ## 2. -optname dbname dbcname value ## 3. -optname ALIAS componenttype option ## 4. -optname ALIAS componenttype option dbname dbcname foreach optdef $optlist { foreach {optname alias type opt dbname dbcname} $optdef break set len [llength $optdef] switch -glob -- $alias { -* { if {$len != 2} { return -code error "wrong \# args for option alias,\ must be: {-aliasoptioname -realoptionname}" } set options($optname) $alias continue } ALIAS - alias { if {$len != 4 && $len != 6} { return -code error "wrong \# args for ALIAS, must be:\ {-optionname ALIAS componenttype option\ ?databasename databaseclass?}" } if {![info exists widgets($type)]} { return -code error "cannot create alias \"$optname\" to\ $CLASS component type \"$type\" option \"$opt\":\ component type does not exist" } elseif {![info exists config($type)]} { if {[string compare toplevel $type]} { set w .__widget__$type catch {destroy $w} ## Make sure the component widget type exists, ## returns the widget name, ## and accepts configure as a subcommand if {[catch {$type $w} result] || \ [string compare $result $w] || \ [catch {$w configure} config($type)]} { ## Make sure we destroy it if it was a bad widget catch {destroy $w} ## Or rename it if it was a non-widget command catch {rename $w {}} return -code error "invalid widget type \"$type\"" } catch {destroy $w} } else { set config($type) [. configure] } } set i [lsearch -glob $config($type) "$opt\[ \t\]*"] if {$i == -1} { return -code error "cannot create alias \"$o\" to $CLASS\ component type \"$type\" option \"$opt\":\ option does not exist" } if {$len==4} { foreach {opt dbname dbcname def} \ [lindex $config($type) $i] break } elseif {$len==6} { set def [lindex [lindex $config($type) $i] 3] } } default { if {$len != 4} { return -code error "wrong \# args for option \"$optdef\",\ must be:\ {-optioname databasename databaseclass defaultval}" } foreach {optname dbname dbcname def} $optdef break } } set options($optname) [list $dbname $dbcname $def] option add *$CLASS.$dbname $def widgetDefault } } ;proc _create {CLASS args} { if {![string match {[A-Z]*} $CLASS] || [string match { } $CLASS]} { return -code error "invalid class name \"$CLASS\": it must begin\ with a capital letter and contain no spaces" } variable CONTAINERS variable CLASSES set namesp [namespace current]::$CLASS namespace eval $namesp { variable class variable options variable components variable widgets catch {unset class} catch {unset options} catch {unset components} catch {unset widgets} } upvar \#0 ${namesp}::class class \ ${namesp}::options options \ ${namesp}::components components \ ${namesp}::widgets widgets get_opts2 classopts $args { -type frame -base frame -components {} -options {} } { -type list -base list -components list -options list } ## First check to see that their container type is valid ## I'd like to include canvas and text, but they don't accept the ## -class option yet, which would thus require some voodoo on the ## part of the constructor to make it think it was the proper class if {![regexp ^([join $CONTAINERS |])\$ $classopts(-type)]} { return -code error "invalid class container type\ \"$classopts(-type)\", must be one of:\ [join $CONTAINERS {, }]" } ## Then check to see that their base widget type is valid ## We will create a default widget of the appropriate type just in ## case they use the DEFAULT keyword as a default value in their ## megawidget class definition if {[info exists classopts(-base)]} { ## We check to see that we can create the base, that it returns ## the same widget value we put in, and that it accepts cget. if {[string match toplevel $classopts(-base)] && \ [string compare toplevel $classopts(-type)]} { return -code error "\"toplevel\" is not allowed as the base\ widget of a megawidget (perhaps you intended it to\ be the class type)" } } else { ## The container is the default base widget set classopts(-base) $classopts(-type) } ## Ensure that the class is set correctly array set class [list class $CLASS \ base $classopts(-base) \ type $classopts(-type)] set widgets($class(type)) 0 if {![info exists classopts(-components)]} { set classopts(-components) {} } foreach compdef $classopts(-components) { set opts {} switch [llength $compdef] { 0 continue 1 { set name [set type [set wid $compdef]] } 2 { set type [lindex $compdef 0] set name [set wid [lindex $compdef 1]] } default { foreach {type name wid opts} $compdef break set opts [string trim $opts] } } if {[info exists components($name)]} { return -code error "component name \"$name\" occurs twice\ in $CLASS class" } if {[info exists widnames($wid)]} { return -code error "widget name \"$wid\" occurs twice\ in $CLASS class" } if {[regexp {(^[\.A-Z]| |\.$)} $wid]} { return -code error "invalid $CLASS class component widget\ name \"$wid\": it cannot begin with a capital letter,\ contain spaces or start or end with a \".\"" } if {[string match *.* $wid] && \ ![info exists widnames([file root $wid])]} { ## If the widget name contains a '.', then make sure we will ## have created all the parents first. [file root $wid] is ## a cheap trick to remove the last .child string from $wid return -code error "no specified parent for $CLASS class\ component widget name \"$wid\"" } if {[string match base $type]} { set type $class(base) set components(base) [list $type $wid $opts $name] if {[string match $type $class(type)]} continue } set components($name) [list $type $wid $opts] set widnames($wid) 0 set widgets($type) 0 } if {![info exists components(base)]} { set components(base) [list $class(base) $class(base) {}] # What should we really do here? #set components($class(base)) $components(base) set widgets($class(base)) 0 if {![regexp ^([join $CONTAINERS |])\$ $class(base)] && \ ![info exists components($class(base))]} { set components($class(base)) $components(base) } } ## Process options add_options $namesp $CLASS $classopts(-options) namespace eval $namesp { set CLASS [namespace tail [namespace current]] ## The _destruct must occur to remove excess state elements. ## The [winfo class %W] will work in this Destroy, which is necessary ## to determine if we are destroying the actual megawidget container. bind $CLASS <Destroy> [namespace code { if {[string compare {} [::widget classes [::winfo class %W]]]} { if [catch {_destruct %W} err] { puts $err } } }] } ## This creates the basic constructor procedure for the class ## as ${namesp}::$CLASS construct $namesp $CLASS ## Both $CLASS and [string tolower $CLASS] commands will be created ## in the global namespace namespace eval $namesp [list namespace export -clear $CLASS] namespace eval :: [list namespace import -force ${namesp}::$CLASS] interp alias {} ::[string tolower $CLASS] {} ::$CLASS ## These are provided so that errors due to lack of the command ## existing don't arise. Since they are stubbed out here, the ## user can't depend on 'unknown' or 'auto_load' to get this proc. if {[string match {} [info commands ${namesp}::construct]]} { ;proc ${namesp}::construct {w} { # the user should rewrite this # without the following error, a simple megawidget that was just # a frame would be created by default return -code error "user must write their own\ [lindex [info level 0] 0] function" } } if {[string match {} [info commands ${namesp}::init]]} { ;proc ${namesp}::init {w} { # the user should rewrite this } } ## The user is not supposed to change this proc set comps [lsort [array names components]] ;proc ${namesp}::_subwidget {w {widget return} args} [subst { variable \$w upvar 0 \$w data switch -- \$widget { return { return [list $comps] } all { if {\[llength \$args\]} { foreach sub [list $comps] { catch {uplevel 1 \[list \$data(\$sub)\] \$args} } } else { return [list $comps] } } [join $comps { - }] { if {\[llength \$args\]} { return \[uplevel 1 \[list \$data(\$widget)\] \$args\] } else { return \$data(\$widget) } } default { return -code error \"No \$data(class) subwidget \\\"\$widget\\\",\ must be one of: [join $comps {, }]\" } } }] ## The user is not supposed to change this proc ## Instead they create a ::Widget::$CLASS::destruct proc ## Some of this may be redundant, but at least it does the job ;proc ${namesp}::_destruct {w} " upvar \#0 ${namesp}::\$w data catch {${namesp}::destruct \$w} catch {::destroy \$data(base)} catch {::destroy \$w} catch {rename \$data(basecmd) {}} catch {rename ::\$data(base) {}} catch {rename ::\$w {}} catch {unset data} return\n" if {[string match {} [info commands ${namesp}::destruct]]} { ## The user can optionally provide a special destroy handler ;proc ${namesp}::destruct {w args} { # empty } } ## The user is not supposed to change this proc ;proc ${namesp}::_cget {w args} { if {[llength $args] != 1} { return -code error "wrong \# args: should be \"$w cget option\"" } set namesp [namespace current] upvar \#0 ${namesp}::$w data ${namesp}::options options if {[info exists options($args)]&&[string match -* $options($args)]} { set args $options($args) } if {[string match {} [set arg [array names data $args]]]} { set arg [array names data ${args}*] } set num [llength $arg] if {$num==1} { return $data($arg) } elseif {$num} { return -code error "ambiguous option \"$args\",\ must be one of: [join $arg {, }]" } elseif {[catch {$data(basecmd) cget $args} err]} { return -code error $err } else { return $err } } ## The user is not supposed to change this proc ## Instead they create a $CLASS:configure proc ;proc ${namesp}::_configure {w args} { set namesp [namespace current] upvar \#0 ${namesp}::$w data ${namesp}::options options \ ${namesp}::components components set num [llength $args] if {$num==1} { ## Request for one config option if {[info exists options($args)] && \ [string match -* $options($args)]} { set args $options($args) } if {[string match {} [set arg [array names data $args]]]} { set arg [array names data ${args}*] } set num [llength $arg] if {$num==1} { ## FIX one-elem config return "[list $arg] $options($arg) [list $data($arg)]" } elseif {$num} { return -code error "ambiguous option \"$args\",\ must be one of: [join $arg {, }]" } elseif {[catch {$data(basecmd) configure $args} err]} { return -code error $err } else { return $err } } elseif {$num} { ## Request for several config options to be set ## Group the {key val} pairs to be distributed if {$num&1} { set last [lindex $args end] set args [lrange $args 0 [incr num -2]] } set widargs {} set cmdargs {} foreach {key val} $args { if {[info exists options($key)] && \ [string match -* $options($key)]} { set key $options($key) } if {[string match {} [set arg [array names data $key]]]} { set arg [array names data $key*] } set len [llength $arg] if {$len==1} { lappend widargs $arg $val } elseif {$len} { set ambarg [list $key $arg] break } else { lappend cmdargs $key $val } } if {[llength $widargs]} { uplevel ${namesp}::configure [list $w] $widargs } # if {[llength $cmdargs]} { # ;proc _configure {w args} { # catch {uplevel [list $w] configure $args} # set n [namespace current] # foreach c [winfo children $w] { # uplevel ${n}::_configure [list $c] $args # } # } # uplevel widget configure [list $w] $cmdargs # } if {[llength $cmdargs] && [catch \ {uplevel [list $data(basecmd)] configure $cmdargs} err]} { return -code error $err } if {[info exists ambarg]} { return -code error "ambiguous option \"[lindex $ambarg 0]\",\ must be one of: [join [lindex $ambarg 1] {, }]" } if {[info exists last]} { return -code error "value for \"$last\" missing" } } else { ## Request for all config options to be printed out foreach opt [$data(basecmd) configure] { set opts([lindex $opt 0]) [lrange $opt 1 end] } foreach opt [array names options] { if {[string match -* $options($opt)]} { set opts($opt) [string range $options($opt) 1 end] } else { set opts($opt) "$options($opt) [list $data($opt)]" } } foreach opt [lsort [array names opts]] { lappend config "$opt $opts($opt)" } return $config } } if {[string match {} [info commands ${namesp}::configure]]} { ## The user is intended to rewrite this one ;proc ${namesp}::configure {w args} { foreach {key val} $args { puts "$w: configure $key to [list $value]" } } } set CLASSES($CLASS) $namesp return $namesp } # Redefine private Tk function tkFocusOK to recognize our widgets # ;proc _tkFocusOK w { if {[llength [info commands widget]] && \ [llength [widget classes [winfo class $w]]]} { return 0 } set code [catch {$w cget -takefocus} value] if {($code == 0) && ($value != "")} { if {$value == 0} { return 0 } elseif {$value == 1} { return [winfo viewable $w] } else { set value [uplevel #0 $value $w] if {$value != ""} { return $value } } } if {![winfo viewable $w]} { return 0 } set code [catch {$w cget -state} value] if {($code == 0) && ($value == "disabled")} { return 0 } regexp Key|Focus "[bind $w] [bind [winfo class $w]]" } }; #end namespace ::Widget namespace eval :: { namespace import -force ::Widget::widget catch {tkFocusOK .}; # we want this auto-loaded interp alias {} tkFocusOK {} widget tkFocusOK } ######################################################################## ########################## EXAMPLES #################################### ######################################################################## ######################################################################## ########################## ScrolledText ################################ ######################################################################## ##------------------------------------------------------------------------ ## PROCEDURE ## scrolledtext ## ## DESCRIPTION ## Implements a ScrolledText mega-widget ## ## ARGUMENTS ## scrolledtext <window pathname> <options> ## ## OPTIONS ## (Any text widget option may be used in addition to these) ## ## -autoscrollbar TCL_BOOLEAN DEFAULT: 1 ## Whether to have dynamic or static scrollbars. ## ## RETURNS: the window pathname ## ## METHODS/SUBCOMMANDS ## These are the subcmds that an instance of this megawidget recognizes. ## Aside from those listed here, it accepts subcmds that are valid for ## text widgets. ## ## subwidget widget ## Returns the true widget path of the specified widget. Valid ## widgets are text, xscrollbar, yscrollbar. ## ## BINDINGS (in addition to default widget bindings) ## ## NAMESPACE & STATE ## The megawidget creates a global array with the classname, and a ## global array which is the name of each megawidget is created. The latter ## array is deleted when the megawidget is destroyed. ## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. ## Other procs that begin with $CLASSNAME are private. For each widget, ## commands named .$widgetname and $CLASSNAME$widgetname are created. ## ## EXAMPLE USAGE: ## ## pack [scrolledtext .st -width 40 -height 10] -fill both -exp 1 ## ##------------------------------------------------------------------------ ## Each widget created will also have a global array created by the ## instantiation procedure that is the name of the widget (represented ## as $w below). There three special key names in the $CLASS array: ## ## -type ## the type of base container we want to use (frame or toplevel). ## This would default to frame. This widget will be created for us ## by the constructor function. The $w array will have a "container" ## key that will point to the exact widget name. ## ## -base ## the base widget type for this class. This key is optional and ## represents what kind of widget will be the base for the class. This ## way we know what default methods/options you'll have. If not ## specified, it defaults to the container type. ## To the global $w array, the key "basecmd" will be added by the widget ## instantiation function to point to a new proc that will be the direct ## accessor command for the base widget ("text" in the case of the ## ScrolledText megawidget). The $w "base" key will be the valid widget ## name (for passing to [winfo] and such), but "basecmd" will be the ## valid direct accessor function ## ## -components ## the component widgets of the megawidget. This is a list of tuples ## (ie: {{listbox listbox} {scrollbar yscrollbar} {scrollbar xscrollbar}}) ## where each item is in the form {widgettype name}. These components ## will be created before the $CLASS::construct proc is called and the $w ## array will have keys with each name pointing to the appropriate ## widget in it. Use these keys to access your subwidgets. It is from ## this component list and the base and type about that the subwidget ## method is created. ## ## -options ## A list of lists, this specifies the ## options that this megawidget handles. The value can either be a ## 3-tuple list of the form {databaseName databaseClass defaultValue}, or ## it can be one element matching -*, which means this key (say -bd) is ## an alias for the option specified in the value (say -borderwidth) ## which must be specified fully somewhere else in the class array. ## ## If the value is a list beginning with "ALIAS", then the option is derived ## from a component of the megawidget. The form of the value must be a list ## with the elements: ## {ALIAS componenttype option ?databasename databaseclass?} ## An example of this would be inheriting a label components anchor: ## {ALIAS label -anchor labelAnchor Anchor} ## If the databasename is not specified, it determines the final options ## database info from the component and uses the components default value. ## Otherwise, just the components default value is used. ## ## The $w array will be populated by the instantiation procedure with the ## default values for all the specified $CLASS options. ## # Create this to make sure there are registered in auto_mkindex # these must come before the [widget create ...] proc ScrolledText args {} proc scrolledtext args {} widget create ScrolledText -type frame -base text -components { {base text text {-xscrollcommand [list $data(xscrollbar) set] \ -yscrollcommand [list $data(yscrollbar) set]}} {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1 \ -command [list $w xview]}} {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1 \ -command [list $w yview]}} } -options { {-autoscrollbar autoScrollbar AutoScrollbar 1} } ## Then we "create" the widget. This makes all the necessary default widget ## routines. It creates the public accessor functions ($CLASSNAME and ## [string tolower $CLASSNAME]) as well as the public cget, configure, destroy ## and subwidget methods. The cget and configure commands work like the ## regular Tk ones. The destroy method is superfluous, as megawidgets will ## respond properly to [destroy $widget] (the Tk destroy command). ## The subwidget method has the following form: ## ## $widget subwidget name ## name - the component widget name ## Returns the widget patch to the component widget name. ## Allows the user direct access to your subwidgets. ## ## THE USER SHOULD PROVIDE AT LEAST THE FOLLOWING: ## ## $NAMESPACE::construct {w} => return value ignored ## w - the widget name, also the name of the global data array ## This procedure is called by the public accessor (instantiation) proc ## right after creating all component widgets and populating the global $w ## array with all the default option values, the "base" key and the key ## names for any other components. The user should then grid/pack all ## subwidgets into $w. At this point, the initial configure has not ## occured, so the widget options are all the default. If this proc ## errors, so does the main creation routine, returning your error. ## ## $NAMESPACE::configure {w args} => return ignored (should be empty) ## w - the widget name, also the name of the global data array ## args - a list of key/vals (already verified to exist) ## The user should process the key/vals however they require If this ## proc errors, so does the main creation routine, returning your error. ## ## THE FOLLOWING IS OPTIONAL: ## ## $NAMESPACE::init {w} => return value ignored ## w - the widget name, also the name of the global data array ## This procedure is called after the public configure routine and after ## the "basecmd" key has been added to the $w array. Ideally, this proc ## would be used to do any widget specific one-time initialization. ## ## $NAMESPACE::destruct {w} => return ignored (should be empty) ## w - the widget name, also the name of the global data array ## A default destroy handler is provided that cleans up after the megawidget ## (all state info), but if special cleanup stuff is needed, you would provide ## it in this procedure. This is the first proc called in the default destroy ## handler. ## namespace eval ::Widget::ScrolledText {; ;proc construct {w} { upvar \#0 [namespace current]::$w data grid $data(text) $data(yscrollbar) -sticky news grid $data(xscrollbar) -sticky ew grid columnconfig $w 0 -weight 1 grid rowconfig $w 0 -weight 1 grid remove $data(yscrollbar) $data(xscrollbar) bind $data(text) <Configure> [namespace code [list resize $w 1]] } ;proc configure {w args} { upvar \#0 [namespace current]::$w data set truth {^(1|yes|true|on)$} foreach {key val} $args { switch -- $key { -autoscrollbar { set data($key) [regexp -nocase $truth $val] if {$data($key)} { resize $w 0 } else { grid $data(xscrollbar) grid $data(yscrollbar) } } } } } # captures xview commands to the text widget ;proc _xview {w args} { upvar \#0 [namespace current]::$w data if {[catch {uplevel $data(basecmd) xview $args} err]} { return -code error $err } } # captures yview commands to the text widget ;proc _yview {w args} { upvar \#0 [namespace current]::$w data if {[catch {uplevel $data(basecmd) yview $args} err]} { return -code error $err } elseif {![winfo ismapped $data(xscrollbar)] && \ [string compare {0 1} [$data(basecmd) xview]]} { ## If the xscrollbar was unmapped, but is now needed, show it grid $data(xscrollbar) } } # captures insert commands to the text widget ;proc _insert {w args} { upvar \#0 [namespace current]::$w data set code [catch {uplevel $data(basecmd) insert $args} err] if {[winfo ismapped $w]} { resize $w 0 } return -code $code $err } # captures delete commands to the text widget ;proc _delete {w args} { upvar \#0 [namespace current]::$w data set code [catch {uplevel $data(basecmd) delete $args} err] if {[winfo ismapped $w]} { resize $w 1 } return -code $code $err } # called when the ScrolledText widget is resized by the user or possibly # needs the scrollbars (de|at)tached due to insert/delete. ;proc resize {w d} { upvar \#0 [namespace current]::$w data ## Only when deleting should we consider removing the scrollbars if {!$data(-autoscrollbar)} return set base $data(basecmd) ## We will have to disable the Configure event temporarily, to ## prevent looping due to a quirk in geometry management where ## adding/removing the scrollbar changes the widget size. set W $data(text) set bind [bind $W <Configure>] bind $W <Configure> {} if {[string compare {0 1} [$base xview]]} { grid $data(xscrollbar) } elseif {$d} { grid remove $data(xscrollbar) } if {[string compare {0 1} [$base yview]]} { grid $data(yscrollbar) } elseif {$d} { grid remove $data(yscrollbar) } ## As with the Configure problem, it can affect the cursor too... $base see insert after 100 [list bind $W <Configure> $bind] } }; #end namespace ::Widget::ScrolledText |