896 lines
23 KiB
Tcl
896 lines
23 KiB
Tcl
# util.tcl --
|
|
#
|
|
# This file implements package ::Utility, 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.
|
|
#
|
|
|
|
## 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 highlight 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::tk
|
|
|
|
namespace eval ::Utility {;
|
|
|
|
foreach namesp [namespace children [namespace current]] {
|
|
namespace import -force ${namesp}::*
|
|
}
|
|
|
|
# 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
|
|
}
|
|
|
|
# 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) 0
|
|
}
|
|
return $rs
|
|
}
|
|
|
|
# flist --
|
|
#
|
|
# list open files and sockets
|
|
#
|
|
# Arguments:
|
|
# pattern restrictive regexp pattern for numbers
|
|
# manum max socket/file number to search until
|
|
# Results:
|
|
# Returns ...
|
|
#
|
|
;proc flist {{pattern .*} {maxnum 1025}} {
|
|
set result {}
|
|
for {set i 1} {$i <= $maxnum} {incr i} {
|
|
if {![regexp $pattern $i]} { continue }
|
|
if {![catch {fconfigure file$i} conf]} {
|
|
lappend result [list file$i $conf]
|
|
}
|
|
if {![catch {fconfigure sock$i} conf]} {
|
|
array set c {-peername {} -sockname {}}
|
|
array set c $conf
|
|
lappend result [list sock$i $c(-peername) $c(-sockname)]
|
|
}
|
|
}
|
|
return $result
|
|
}
|
|
|
|
|
|
# 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}]
|
|
}
|
|
|
|
|
|
# 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
|
|
}
|
|
|
|
# getrandfile --
|
|
#
|
|
# returns a random line from a file
|
|
#
|
|
# Arguments:
|
|
# file filename to get line from
|
|
# Results:
|
|
# Returns a line as a string
|
|
#
|
|
;proc getrandfile {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())}]
|
|
}
|
|
|
|
# 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 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
|
|
}
|
|
|
|
# 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
|
|
return [expr {![catch {expr {1*$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
|