Setok's Tcl Utils

Artifact [f27dafc627]
Login

Artifact f27dafc627af797f98913fe375ce6ff284be9e654da6827b106389934d6d4322:


## 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