## Some general utilities useful for many Tcl applications
## Authors: Kristoffer Lawson, setok@setok.co
package provide setok::utils 1.0
# We create a namespace which can be used by procedures here. At some point
# I will probably move the procedures themselves into this namespace
namespace eval setok::utils {
namespace export textToWords safeCmd getsBG buildScript scriptToList tokenSplit
namespace export do multiSet parseOpts
namespace import ::tcl::mathop::*
## Splits a text into alphanumeric words (removing punctuation) as per
## the definition of [string wordstart] and [string wordend].
## Returns list of words
proc textToWords {text} {
set i 0
set words [list]
while {$i < [string length $text]} {
set e [string wordend $text $i]
set w [string range $text $i $e-1]
if { ([string length $w] > 1) || [string is alpha $w]} {
lappend words $w
}
incr i [- $e $i]
}
return $words
}
## Creates a list, based on the list 'cmd', that can be safely evaled. This
## is equivalent to what [list] does to its arguments but manages a list
## instead of args. This is necessary for commands that might have been
## received from an external source and not for ones created by using
## [list].
proc safeCmd {cmd} {
set newCmd [list]
foreach word $cmd {
set word [string trim $word]
if {[string index $word 0] != "\{"} {
if {[string match {[\[\]\$\;]} $word]} {
# Found something that must be put inside braces to avoid
# problems with eval.
set word "\{$word\}"
}
}
lappend newCmd $word
}
return $newCmd
}
## The same as [gets], except that it works when 'chan' is in non-blocking
## mode and while waiting for input, the event loop is started.
##
## Warning: this command should probably only be used from a callback
## set up with fileevent. Be careful of the following:
##
## proc newClient {sock addr port} {
## while {1} {
## set line [getsBG $sock]
## }
## }
##
## While the event loop is started and events handled this will not work
## with multiple clients. Reason: a new client will enter a while loop
## that does not return and thus execution will never assume at the previous
## client's position (Tcl event handlers are always allowed to execute
## to the end, before previous executions are continued). The proper way
## is to use fileevent to call [getsBG] to get the line.
proc getsBG {chan} {
global setok::utils::ReadableStatus
# See that index is unique and does not conflict with other getsBGs
set i 0
while {[info exists ReadableStatus($chan,$i)]} {
incr i
}
set ReadableStatus($chan,$i) 0
set oldScript [fileevent $chan readable]
fileevent $chan readable \
[list set ::setok::utils::ReadableStatus($chan,$i) 1]
set rc -1
# We continue trying to get data until [gets] returns a complete line.
set line ""
while {($rc == -1) && ![eof $chan]} {
vwait ::setok::utils::ReadableStatus($chan,$i)
unset ReadableStatus($chan,$i)
set rc [gets $chan line]
}
fileevent $chan readable $oldScript
return $line
}
## Provides a handy way to dynamically build script by using lists.
## Each list given as an argument is one command line.
##
## Return: Body of script which can then be evaled.
proc buildScript {args} {
foreach cmd $args {
append script $cmd "\n"
}
return $script
}
## Split a script into list elements so that each element of the list is
## a command line from the script. Comment lines are ignored. Does not care
## about the exact content of each command line (does not check for existing
## commands etc), but it should be syntatically correct.
##
## Return: List of command lines
proc scriptToList {script} {
# Build each 'command', marking a section of the spec
set command ""
set commands [list]
set script [string trim $script]
foreach line [split $script "\n"] {
set trimmedLine [string trim $line]
if {([string match {\#*} $trimmedLine]) ||
([string length $trimmedLine] == 0)
} {
# Comment or empty line, ignore
continue
}
append command $line \n
if {[info complete $command]} {
# Trimming not really needed but gives neater command lines
lappend commands [string trim $command]
set command ""
}
}
return $commands
}
## Splits a string up into a list based on "token". This differs from [split]
## in that it searches for exact matches of "token" from "string" instead of
## any character from the group.
proc tokenSplit {string token} {
set startIdx 0
set tokLen [string length $token]
# As long as we can still find new tokens
while {[set endIdx [string first $token $string $startIdx]] != -1} {
lappend r [string range $string $startIdx [- $endIdx 1]]
set startIdx [+ $endIdx $tokLen]
}
if {$startIdx != [string length $string]} {
# If there is something left over at the end, add it to the list.
lappend r [string range $string $startIdx end]
}
return $r
}
## Implements a "do <script> while <expression>" loop.
## The "while" keyword is optional.
##
## Based on do...until by Reinhard Max <max@suse.de>
## at the Texas Tcl Shoot-Out 2000
## in Austin, Texas.
proc do {script arg2 {arg3 {}}} {
if {[string compare $arg3 {}]} {
if {[string compare $arg2 while]} {
return -code 1 "Error: do script ?while? expression"
}
} else {
# copy the expression to arg3, if only
# two arguments are supplied
set arg3 $arg2
}
set ret [catch { uplevel $script } result]
switch $ret {
0 -
4 {}
3 {return}
default {
return -code $ret $result
}
}
set ret [catch {uplevel [list while "($arg3)" $script]} result]
return -code $ret $result
}
## Sets multiple variables in 'varList' at a time from 'valueList'.
proc multiSet {varList valueList} {
uplevel [list foreach $varList $valueList break]
return
}
## Parses program arguments with short and long options. Short options
## use a single dash followed by a single letter, while long options
## use two dashes and an arbitrary amount of letters. Options must appear
## before other arguments of the program.
##
## 'argv' List of arguments to parse.
## 'argArray' Name reference to array that will contain the parsed
## arguments. This can be set up to contain default values prior to calling
## this function.
##
## Each array element contains an option (without the dashes). The element
## 'args' contains the rest of the arguments after the list of options.
proc parseOpts {argv *argArray} {
upvar ${*argArray} argArray
# Get all options first
set i 0
while {[string match "-*" [lindex $argv $i]] && \
$i < [llength $argv]} {
if {$i+1 == [llength $argv]} {
# No value for option
break
}
set opt [string trimleft [lindex $argv $i] "-"]
incr i
set argArray($opt) [lindex $argv $i]
incr i
}
set argArray(args) [lrange $argv $i end]
}
} ;# End of setok namespace