1# util.tcl -- 2# 3# This file implements package ::Utility, which ... 4# 5# Copyright (c) 1997-8 Jeffrey Hobbs 6# 7# See the file "license.terms" for information on usage and 8# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10 11## The provide goes first to prevent the recursive provide/require 12## loop for subpackages 13package provide ::Utility 1.0 14 15## This assumes that all util-*.tcl files are in the same directory 16if {[lsearch -exact $auto_path [file dirname [info script]]]==-1} { 17 lappend auto_path [file dirname [info script]] 18} 19 20namespace eval ::Utility {; 21 22## Protos 23namespace export -clear * 24 25proc get_opts args {} 26proc get_opts2 args {} 27proc lremove args {} 28proc lrandomize args {} 29proc lunique args {} 30proc luniqueo args {} 31proc line_append args {} 32proc highlight args {} 33proc echo args {} 34proc alias args {} 35proc which args {} 36proc ls args {} 37proc dir args {} 38proc fit_format args {} 39proc validate args {} 40proc allow_null_elements args {} 41proc deny_null_elements args {} 42 43}; # end of ::Utility namespace prototype headers 44 45package require ::Utility::number 46package require ::Utility::string 47package require ::Utility::dump 48package require ::Utility::expand 49package require ::Utility::tk 50 51namespace eval ::Utility {; 52 53foreach namesp [namespace children [namespace current]] { 54 namespace import -force ${namesp}::* 55} 56 57# psource -- 58# 59# ADD COMMENTS HERE 60# 61# Arguments: 62# args comments 63# Results: 64# Returns ... 65# 66;proc psource {file namesp {import *}} { 67 uplevel \#0 [subst { 68 source $file 69 namespace import -force ${namesp}::$import 70 } 71 ] 72} 73 74# get_opts -- 75# 76# Processes -* named options, with or w/o possible associated value 77# and returns remaining args 78# 79# Arguments: 80# var variable into which option values should be stored 81# arglist argument list to parse 82# optlist list of valid options with default value 83# typelist optional list of option types that can be used to 84# validate incoming options 85# nocomplain whether to complain about unknown -switches (0 - default) 86# or not (1) 87# Results: 88# Returns unprocessed arguments. 89# 90;proc get_opts {var arglist optlist {typelist {}} {nocomplain 0}} { 91 upvar 1 $var data 92 93 if {![llength $optlist] || ![llength $arglist]} { return $arglist } 94 array set opts $optlist 95 array set types $typelist 96 set i 0 97 while {[llength $arglist]} { 98 set key [lindex $arglist $i] 99 if {[string match -- $key]} { 100 set arglist [lreplace $arglist $i $i] 101 break 102 } elseif {![string match -* $key]} { 103 break 104 } elseif {[string match {} [set akey [array names opts $key]]]} { 105 set akey [array names opts ${key}*] 106 } 107 switch [llength $akey] { 108 0 { ## oops, no keys matched 109 if {$nocomplain} { 110 incr i 111 } else { 112 return -code error "unknown switch '$key', must be:\ 113 [join [array names opts] {, }]" 114 } 115 } 116 1 { ## Perfect, found just the right key 117 if {$opts($akey)} { 118 set val [lrange $arglist [expr {$i+1}] \ 119 [expr {$i+$opts($akey)}]] 120 set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]] 121 if {[info exists types($akey)] && \ 122 ([string compare none $types($akey)] && \ 123 ![validate $types($akey) $val])} { 124 return -code error "the value for \"$akey\" is not in\ 125 proper $types($akey) format" 126 } 127 set data($akey) $val 128 } else { 129 set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]] 130 set data($akey) 1 131 } 132 } 133 default { ## Oops, matches too many possible keys 134 return -code error "ambiguous option \"$key\",\ 135 must be one of: [join $akey {, }]" 136 } 137 } 138 } 139 return $arglist 140} 141 142# get_opts2 -- 143# 144# Process options into an array. -- short-circuits the processing 145# 146# Arguments: 147# var variable into which option values should be stored 148# arglist argument list to parse 149# optlist list of valid options with default value 150# typelist optional list of option types that can be used to 151# validate incoming options 152# Results: 153# Returns unprocessed arguments. 154# 155;proc get_opts2 {var arglist optlist {typelist {}}} { 156 upvar 1 $var data 157 158 if {![llength $optlist] || ![llength $arglist]} { return $arglist } 159 array set data $optlist 160 array set types $typelist 161 foreach {key val} $arglist { 162 if {[string match -- $key]} { 163 set arglist [lreplace $arglist 0 0] 164 break 165 } 166 if {[string match {} [set akey [array names data $key]]]} { 167 set akey [array names data ${key}*] 168 } 169 switch [llength $akey] { 170 0 { ## oops, no keys matched 171 return -code error "unknown switch '$key', must be:\ 172 [join [array names data] {, }]" 173 } 174 1 { ## Perfect, found just the right key 175 if {[info exists types($akey)] && \ 176 ![validate $types($akey) $val]} { 177 return -code error "the value for \"$akey\" is not in\ 178 proper $types($akey) format" 179 } 180 set data($akey) $val 181 } 182 default { ## Oops, matches too many possible keys 183 return -code error "ambiguous option \"$key\",\ 184 must be one of: [join $akey {, }]" 185 } 186 } 187 set arglist [lreplace $arglist 0 1] 188 } 189 return $arglist 190} 191 192# lremove -- 193# remove items from a list 194# Arguments: 195# ?-all? remove all instances of said item 196# list list to remove items from 197# args items to remove 198# Returns: 199# The list with items removed 200# 201;proc lremove {args} { 202 set all 0 203 if {[string match \-a* [lindex $args 0]]} { 204 set all 1 205 set args [lreplace $args 0 0] 206 } 207 set l [lindex $args 0] 208 foreach i [join [lreplace $args 0 0]] { 209 if {[set ix [lsearch -exact $l $i]] == -1} continue 210 set l [lreplace $l $ix $ix] 211 if {$all} { 212 while {[set ix [lsearch -exact $l $i]] != -1} { 213 set l [lreplace $l $ix $ix] 214 } 215 } 216 } 217 return $l 218} 219 220# lrandomize -- 221# randomizes a list 222# Arguments: 223# ls list to randomize 224# Returns: 225# returns list in with randomized items 226# 227;proc lrandomize ls { 228 set res {} 229 while {[string compare $ls {}]} { 230 set i [randrng [llength $ls]] 231 lappend res [lindex $ls $i] 232 set ls [lreplace $ls $i $i] 233 } 234 return $res 235} 236 237# lunique -- 238# order independent list unique proc, not most efficient. 239# Arguments: 240# ls list of items to make unique 241# Returns: 242# list of only unique items, order not defined 243# 244;proc lunique ls { 245 foreach l $ls {set ($l) x} 246 return [array names {}] 247} 248 249# lunique -- 250# order independent list unique proc. most efficient, but requires 251# __LIST never be an element of the input list 252# Arguments: 253# __LIST list of items to make unique 254# Returns: 255# list of only unique items, order not defined 256# 257;proc lunique __LIST { 258 if {[llength $__LIST]} { 259 foreach $__LIST $__LIST break 260 unset __LIST 261 return [info locals] 262 } 263} 264 265# luniqueo -- 266# order dependent list unique proc 267# Arguments: 268# ls list of items to make unique 269# Returns: 270# list of only unique items in same order as input 271# 272;proc luniqueo ls { 273 set rs {} 274 foreach l $ls { 275 if {[info exist ($l)]} { continue } 276 lappend rs $l 277 set ($l) 0 278 } 279 return $rs 280} 281 282# flist -- 283# 284# list open files and sockets 285# 286# Arguments: 287# pattern restrictive regexp pattern for numbers 288# manum max socket/file number to search until 289# Results: 290# Returns ... 291# 292;proc flist {{pattern .*} {maxnum 1025}} { 293 set result {} 294 for {set i 1} {$i <= $maxnum} {incr i} { 295 if {![regexp $pattern $i]} { continue } 296 if {![catch {fconfigure file$i} conf]} { 297 lappend result [list file$i $conf] 298 } 299 if {![catch {fconfigure sock$i} conf]} { 300 array set c {-peername {} -sockname {}} 301 array set c $conf 302 lappend result [list sock$i $c(-peername) $c(-sockname)] 303 } 304 } 305 return $result 306} 307 308 309# highlight -- 310# 311# searches in text widget for $str and highlights it 312# If $str is empty, it just deletes any highlighting 313# This really belongs in ::Utility::tk 314# 315# Arguments: 316# w text widget 317# str string to search for 318# -nocase specifies to be case insensitive 319# -regexp specifies that $str is a pattern 320# -tag tagId name of tag in text widget 321# -color color color of tag in text widget 322# Results: 323# Returns ... 324# 325;proc highlight {w str args} { 326 $w tag remove __highlight 1.0 end 327 array set opts { 328 -nocase 0 329 -regexp 0 330 -tag __highlight 331 -color yellow 332 } 333 set args [get_opts opts $args {-nocase 0 -regexp 0 -tag 1 -color 1}] 334 if {[string match {} $str]} return 335 set pass {} 336 if {$opts(-nocase)} { append pass "-nocase " } 337 if {$opts(-regexp)} { append pass "-regexp " } 338 $w tag configure $opts(-tag) -background $opts(-color) 339 $w mark set $opts(-tag) 1.0 340 while {[string compare {} [set ix [eval $w search $pass -count numc -- \ 341 [list $str] $opts(-tag) end]]]} { 342 $w tag add $opts(-tag) $ix ${ix}+${numc}c 343 $w mark set $opts(-tag) ${ix}+1c 344 } 345 catch {$w see $opts(-tag).first} 346 return [expr {[llength [$w tag ranges $opts(-tag)]]/2}] 347} 348 349 350# best_match -- 351# finds the best unique match in a list of names 352# The extra $e in this argument allows us to limit the innermost loop a 353# little further. 354# Arguments: 355# l list to find best unique match in 356# e currently best known unique match 357# Returns: 358# longest unique match in the list 359# 360;proc best_match {l {e {}}} { 361 set ec [lindex $l 0] 362 if {[llength $l]>1} { 363 set e [string length $e]; incr e -1 364 set ei [string length $ec]; incr ei -1 365 foreach l $l { 366 while {$ei>=$e && [string first $ec $l]} { 367 set ec [string range $ec 0 [incr ei -1]] 368 } 369 } 370 } 371 return $ec 372} 373 374# getrandfile -- 375# 376# returns a random line from a file 377# 378# Arguments: 379# file filename to get line from 380# Results: 381# Returns a line as a string 382# 383;proc getrandfile {file} { 384 set fid [open $file] 385 set data [split [read $fid] \n] 386 close $fid 387 return [lindex $data [randrng [llength $data]]] 388} 389 390# randrng -- 391# gets random number within input range 392# Arguments: 393# rng range to limit output to 394# Returns: 395# returns random number within range 0..$rng 396;proc randrng {rng} { 397 return [expr {int($rng * rand())}] 398} 399 400# grep -- 401# cheap grep routine 402# Arguments: 403# exp regular expression to look for 404# args files to search in 405# Returns: 406# list of lines that in files that matched $exp 407# 408;proc grep {exp args} { 409 if 0 { 410 ## To be implemented 411 -count -nocase -number -names -reverse -exact 412 } 413 if {[string match {} $args]} return 414 set output {} 415 foreach file [eval glob $args] { 416 set fid [open $file] 417 foreach line [split [read $fid] \n] { 418 if {[regexp $exp $line]} { lappend output $line } 419 } 420 close $fid 421 } 422 return $output 423} 424 425# line_append -- 426# appends a string to the end of every line of data from a file 427# Arguments: 428# file file to get data from 429# stuff stuff to append to each line 430# Returns: 431# file data with stuff appended to each line 432# 433;proc line_append {file stuff} { 434 set fid [open $file] 435 set data [read $fid] 436 catch {close $fid} 437 return [join [split $data \n] $stuff\n] 438} 439 440 441# alias -- 442# akin to the csh alias command 443# Arguments: 444# newcmd (optional) command to bind alias to 445# args command and args being aliased 446# Returns: 447# If called with no args, then it dumps out all current aliases 448# If called with one arg, returns the alias of that arg (or {} if none) 449# 450;proc alias {{newcmd {}} args} { 451 if {[string match {} $newcmd]} { 452 set res {} 453 foreach a [interp aliases] { 454 lappend res [list $a -> [interp alias {} $a]] 455 } 456 return [join $res \n] 457 } elseif {[string match {} $args]} { 458 interp alias {} $newcmd 459 } else { 460 eval interp alias [list {} $newcmd {}] $args 461 } 462} 463 464# echo -- 465# Relaxes the one string restriction of 'puts' 466# Arguments: 467# args any number of strings to output to stdout 468# Returns: 469# Outputs all input to stdout 470# 471;proc echo args { puts [concat $args] } 472 473# which -- 474# tells you where a command is found 475# Arguments: 476# cmd command name 477# Returns: 478# where command is found (internal / external / unknown) 479# 480;proc which cmd { 481 ## FIX - make namespace friendly 482 set lcmd [list $cmd] 483 if { 484 [string compare {} [uplevel info commands $lcmd]] || 485 ([uplevel auto_load $lcmd] && 486 [string compare {} [uplevel info commands $lcmd]]) 487 } { 488 set ocmd [uplevel namespace origin $lcmd] 489 # First check to see if it is an alias 490 # This requires two checks because interp aliases doesn't 491 # canonically return fully (un)qualified names 492 set aliases [interp aliases] 493 if {[lsearch -exact $aliases $ocmd] > -1} { 494 set result "$cmd: aliased to \"[alias $ocmd]\"" 495 } elseif {[lsearch -exact $aliases $cmd] > -1} { 496 set result "$cmd: aliased to \"[alias $cmd]\"" 497 } elseif {[string compare {} [uplevel info procs $lcmd]] || \ 498 ([string match ?*::* $ocmd] && \ 499 [string compare {} [namespace eval \ 500 [namespace qualifiers $ocmd] \ 501 [list info procs [namespace tail $ocmd]]]])} { 502 # Here we checked if the proc that has been imported before 503 # deciding it is a regular command 504 set result "$cmd: procedure $ocmd" 505 } else { 506 set result "$cmd: command" 507 } 508 global auto_index 509 if {[info exists auto_index($cmd)]} { 510 # This tells you where the command MIGHT have come from - 511 # not true if the command was redefined interactively or 512 # existed before it had to be auto_loaded. This is just 513 # provided as a hint at where it MAY have come from 514 append result " ($auto_index($cmd))" 515 } 516 return $result 517 } elseif {[string compare {} [auto_execok $cmd]]} { 518 return [auto_execok $cmd] 519 } else { 520 return -code error "$cmd: command not found" 521 } 522} 523 524# ls -- 525# mini-ls equivalent (directory lister) 526# Arguments: 527# ?-all? list hidden files as well (Unix dot files) 528# ?-long? list in full format "permissions size date filename" 529# ?-full? displays / after directories and link paths for links 530# args names/glob patterns of directories to list 531# Returns: 532# a directory listing 533# 534interp alias {} ::Utility::dir {} namespace inscope ::Utility ls 535;proc ls {args} { 536 array set s { 537 -all 0 -full 0 -long 0 538 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx 539 } 540 set args [get_opts s $args [array get s -*]] 541 set sep [string trim [file join . .] .] 542 if {[string match {} $args]} { set args . } 543 foreach arg $args { 544 if {[file isdir $arg]} { 545 set arg [string trimr $arg $sep]$sep 546 if {$s(-all)} { 547 lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] 548 } else { 549 lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] 550 } 551 } else { 552 lappend out [list [file dirname $arg]$sep \ 553 [lsort [glob -nocomplain -- $arg]]] 554 } 555 } 556 if {$s(-long)} { 557 global tcl_platform 558 set old [clock scan {1 year ago}] 559 switch -exact -- $tcl_platform(os) { 560 windows { set fmt "%-5s %8d %s %s\n" } 561 default { set fmt "%s %-8s %-8s %8d %s %s\n" } 562 } 563 foreach o $out { 564 set d [lindex $o 0] 565 if {[llength $out]>1} { append res $d:\n } 566 foreach f [lindex $o 1] { 567 file lstat $f st 568 array set st [file attrib $f] 569 set f [file tail $f] 570 if {$s(-full)} { 571 switch -glob $st(type) { 572 dir* { append f $sep } 573 link { append f " -> [file readlink $d$sep$f]" } 574 fifo { append f | } 575 default { if {[file exec $d$sep$f]} { append f * } } 576 } 577 } 578 switch -exact -- $st(type) { 579 file { set mode - } 580 fifo { set mode p } 581 default { set mode [string index $st(type) 0] } 582 } 583 set cfmt [expr {$st(mtime)>$old?{%b %d %H:%M}:{%b %d %Y}}] 584 switch -exact -- $tcl_platform(os) { 585 windows { 586 # RHSA 587 append mode $st(-readonly) $st(-hidden) \ 588 $st(-system) $st(-archive) 589 append res [format $fmt $mode $st(size) \ 590 [clock format $st(mtime) -format $cfmt] $f] 591 } 592 macintosh { 593 append mode $st(-readonly) $st(-hidden) 594 append res [format $fmt $mode $st(-creator) \ 595 $st(-type) $st(size) \ 596 [clock format $st(mtime) -format $cfmt] $f] 597 } 598 default { ## Unix is our default platform type 599 foreach j [split [format %o \ 600 [expr {$st(mode)&0777}]] {}] { 601 append mode $s($j) 602 } 603 append res [format $fmt $mode $st(-owner) $st(-group) \ 604 $st(size) \ 605 [clock format $st(mtime) -format $cfmt] $f] 606 } 607 } 608 } 609 append res \n 610 } 611 } else { 612 foreach o $out { 613 set d [lindex $o 0] 614 if {[llength $out]>1} { append res $d:\n } 615 set i 0 616 foreach f [lindex $o 1] { 617 if {[string len [file tail $f]] > $i} { 618 set i [string len [file tail $f]] 619 } 620 } 621 set i [expr {$i+2+$s(-full)}] 622 ## Assume we have at least 70 char cols 623 set j [expr {70/$i}] 624 set k 0 625 foreach f [lindex $o 1] { 626 set f [file tail $f] 627 if {$s(-full)} { 628 switch -glob [file type $d$sep$f] { 629 d* { append f $sep } 630 l* { append f @ } 631 default { if {[file exec $d$sep$f]} { append f * } } 632 } 633 } 634 append res [format "%-${i}s" $f] 635 if {[incr k]%$j == 0} {set res [string trimr $res]\n} 636 } 637 append res \n\n 638 } 639 } 640 return [string trimr $res] 641} 642 643# fit_format -- 644# This procedure attempts to format a value into a particular format string. 645# 646# Arguments: 647# format - The format to fit 648# val - The value to be validated 649# 650# Returns: 0 or 1 (whether it fits the format or not) 651# 652# Switches: 653# -fill ?var? - Default values will be placed to fill format to spec 654# and the resulting value will be placed in variable 'var'. 655# It will equal {} if the match invalid 656# (doesn't work all that great currently) 657# -best ?var? - 'Fixes' value to fit format, placing best correct value 658# in variable 'var'. If current value is ok, the 'var' 659# will equal it, otherwise it removes chars from the end 660# until it fits the format, then adds any fixed format 661# chars to value. Can be slow (recursive tkFormat op). 662# -strict - Value must be an exact match for format (format && length) 663# -- - End of switches 664 665;proc fit_format {args} { 666 set fill {}; set strict 0; set best {}; set result 1; 667 set name [lindex [info level 0] 0] 668 while {[string match {-*} [lindex $args 0]]} { 669 switch -- [string index [lindex $args 0] 1] { 670 b { 671 set best [lindex $args 1] 672 set args [lreplace $args 0 1] 673 } 674 f { 675 set fill [lindex $args 1] 676 set args [lreplace $args 0 1] 677 } 678 s { 679 set strict 1 680 set args [lreplace $args 0 0] 681 } 682 - { 683 set args [lreplace $args 0 0] 684 break 685 } 686 default { 687 return -code error "bad $name option \"[lindex $args 0]\",\ 688 must be: -best, -fill, -strict, or --" 689 } 690 } 691 } 692 693 if {[llength $args] != 2} { 694 return -code error "wrong \# args: should be \"$name ?-best varname?\ 695 ?-fill varname? ?-strict? ?--? format value\"" 696 } 697 set format [lindex $args 0] 698 set val [lindex $args 1] 699 700 set flen [string length $format] 701 set slen [string length $val] 702 if {$slen > $flen} {set result 0} 703 if {$strict} { if {$slen != $flen} {set result 0} } 704 705 if {$result} { 706 set regform {} 707 foreach c [split $format {}] { 708 set special 0 709 if {[string match {[0AaWzZ]} $c]} { 710 set special 1 711 switch $c { 712 0 {set fmt {[0-9]}} 713 A {set fmt {[A-Z]}} 714 a {set fmt {[a-z]}} 715 W {set fmt "\[ \t\r\n\]"} 716 z {set fmt {[A-Za-z]}} 717 Z {set fmt {[A-Za-z0-9]}} 718 } 719 } else { 720 set fmt $c 721 } 722 723 } 724 echo $regform $format $val 725 set result [string match $regform $val] 726 } 727 728 if [string compare $fill {}] { 729 upvar $fill fvar 730 if {$result} { 731 set fvar $val[string range $format $i end] 732 } else { 733 set fvar {} 734 } 735 } 736 737 if [string compare $best {}] { 738 upvar $best bvar 739 set bvar $val 740 set len [string length $bvar] 741 if {!$result} { 742 incr len -2 743 set bvar [string range $bvar 0 $len] 744 # Remove characters until it's in valid format 745 while {$len > 0 && ![tkFormat $format $bvar]} { 746 set bvar [string range $bvar 0 [incr len -1]] 747 } 748 # Add back characters that are fixed 749 while {($len<$flen) && ![string match \ 750 {[0AaWzZ]} [string index $format [incr len]]]} { 751 append bvar [string index $format $len] 752 } 753 } else { 754 # If it's already valid, at least we can add fixed characters 755 while {($len<$flen) && ![string match \ 756 {[0AaWzZ]} [string index $format $len]]} { 757 append bvar [string index $format $len] 758 incr len 759 } 760 } 761 } 762 763 return $result 764} 765 766 767# validate -- 768# This procedure validates particular types of numbers/formats 769# 770# Arguments: 771# type - The type of validation (alphabetic, alphanumeric, date, 772# hex, integer, numeric, real). Date is always strict. 773# val - The value to be validated 774# 775# Returns: 0 or 1 (whether or not it resembles the type) 776# 777# Switches: 778# -incomplete enable less precise (strict) pattern matching on number 779# useful for when the number might be half-entered 780# 781# Example use: validate real 55e-5 782# validate -incomplete integer -505 783# 784 785;proc validate {args} { 786 if {[string match [lindex $args 0]* "-incomplete"]} { 787 set strict 0 788 set opt * 789 set args [lreplace $args 0 0] 790 } else { 791 set strict 1 792 set opt + 793 } 794 795 if {[llength $args] != 2} { 796 return -code error "wrong \# args: should be\ 797 \"[lindex [info level 0] 0] ?-incomplete? type value\"" 798 } else { 799 set type [lindex $args 0] 800 set val [lindex $args 1] 801 } 802 803 ## This is a big switch for speed reasons 804 switch -glob -- $type { 805 alphab* { # alphabetic 806 return [regexp -nocase "^\[a-z\]$opt\$" $val] 807 } 808 alphan* { # alphanumeric 809 return [regexp -nocase "^\[a-z0-9\]$opt\$" $val] 810 } 811 b* { # boolean - would be nice if it were more than 0/1 812 return [regexp "^\[01\]$opt\$" $val] 813 } 814 d* { # date - always strict 815 return [expr {![catch {clock scan $val}]}] 816 } 817 h* { # hexadecimal 818 return [regexp -nocase "^(0x)?\[0-9a-f\]$opt\$" $val] 819 } 820 i* { # integer 821 return [regexp "^\[-+\]?\[0-9\]$opt\$" $val] 822 } 823 n* { # numeric 824 return [regexp "^\[0-9\]$opt\$" $val] 825 } 826 rea* { # real 827 return [regexp -nocase [expr {$strict 828 ?{^[-+]?([0-9]+\.?[0-9]*|[0-9]*\.?[0-9]+)(e[-+]?[0-9]+)?$} 829 :{^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}}] $val] 830 } 831 reg* { # regexp 832 return [expr {![catch {regexp $val {}}]}] 833 } 834 val* { # value 835 return [expr {![catch {expr {1*$val}}]}] 836 } 837 l* { # list 838 return [expr {![catch {llength $val}]}] 839 } 840 w* { # widget 841 return [winfo exists $val] 842 } 843 default { 844 return -code error "bad [lindex [info level 0] 0] type \"$type\":\ 845 \nmust be [join [lsort {alphabetic alphanumeric date \ 846 hexadecimal integer numeric real value \ 847 list boolean}] {, }]" 848 } 849 } 850 return 851} 852 853# allow_null_elements -- 854# 855# Sets up a read trace on an array to allow reading any value 856# and ensure that some default exists 857# 858# Arguments: 859# args comments 860# Results: 861# Returns ... 862# 863;proc allow_null_elements {array {default {}}} { 864 uplevel 1 [list trace variable $array r [list \ 865 [namespace code ensure_default] $default]] 866} 867 868;proc ensure_default {val array idx op} { 869 upvar $array var 870 if {[array exists var]} { 871 if {![info exists var($idx)]} { 872 set var($idx) $val 873 } 874 } elseif {![info exists var]} { 875 set var $val 876 } 877} 878 879# deny_null_elements -- 880# 881# ADD COMMENTS HERE 882# 883# Arguments: 884# args comments 885# Results: 886# Returns ... 887# 888;proc deny_null_elements {array {default {}}} { 889 ## FIX: should use vinfo and remove any *ensure_default* read traces 890 uplevel 1 [list trace vdelete $array r [list \ 891 [namespace code ensure_default] $default]] 892} 893 894 895}; # end namespace ::Utility 896