Tcl Code Fragments

Giving your procs static variables

proc static {varname {initval 0}} {

    # determine the name of the proc that invoked us:
    
    set procname [lindex [info level -1] 0]
    global $procname

    # initialize only if the variable doesn't already exist:
    
    if ![info exists [set procname]($varname)] {
	set [set procname]($varname) $initval
    }

    # make the global variable accessible from within the invoking proc
    # and return its current value:
    
    uplevel upvar #0 [set procname]($varname) $varname
    return [set [set procname]($varname)]
}

    proc static {args} {
        set procName [lindex [info level -1] 0]
        foreach varName $args {
        uplevel 1 "upvar #0 staticvars($procName:$varName) $varName"
        }
    }

Dumping the Keys and values of a TclX keyed list

proc pkeyl { keylnm } {
    upvar $keylnm keyl
    puts stderr "$keylnm :"
    set l [ keylkeys keyl ]
    foreach i $l {
        set v [ keylget keyl $i ]
        puts stderr [format "%20s = %-s" $i $v]
    }
}

Dumping the value of an arbitrary Tcl variable

# Print out the value of a variable (array or simple) by 
# just passing it the variable  name
proc dumpvar var {
  upvar $var v
  if {[set ix [array names v]] != ""} {
    foreach i $ix {append res [list set $var\($i) $v($i)]\n}
  } elseif [info exists v] {
    if [catch {list set $var $v} res] {set res "No known variable [list $var]"}
  } else {
    set res "No known variable [list $var]"
  }
  return $res
}

Ascii and integer conversions

# convert integer to ascii char
proc asc i { 
    if { $i<0 || $i>255 } { error "asc:Integer out of range 0-255" } 
    return [format %c $i ] 
}

proc chr c { 
    if {[string length $c] > 1 } { error "chr: arg should be a single char"}
#   set c [ string range $c 0 0] 
    set v 0; 
    scan $c %c v; return $v
}

An Incr proc resistant to nonexistant variables

proc Incr { name {value 1 } } {
upvar $name var

    if { [ info exists var ] }  {
	set var [ expr $var + $value ]
    } else {
	set var $value 
    }
}

Random number generators

From Libes "Exploring Expect" p525. See also Welch p52.

# if random is not avalable from libtclx.so
if {[info commands random] == ""} {
    # initialize seed.  
    set _rand [pid]
    # random returns a value in the range 0..range-1
    proc random {range} {
        global _rand
	set period 233280
        set _rand [expr ($_rand * 9301 + 49297) % $period]
        expr int(($_rand/double($period)) * $range)
    }
}

### QUICK AND DIRTY - works on all platforms
set _ran [pid]
proc random {range} {
  global _ran
  set _ran [expr ($_ran * 9301 + 49297) % 233280]
  return [expr int($range * ($_ran / double(233280)))]
}

### SAME SYNTAX AS TCLX random - UNIX dependent
proc random {args} {
  global RNG_seed

  set max 259200
  set argcnt [llength $args]
  if { $argcnt < 1 || $argcnt > 2 } {
    error "wrong # args: random limit | seed ?seedval?"
  }
  if [string match [lindex $args 0] seed] {
    if { $argcnt == 2 } {
      set RNG_seed [lindex $args 1]
    } else {
      set RNG_seed [expr ([pid]+[file atime /dev/kmem])%$max]
    }
    return
  }
	
# You could replace '[file atime /dev/kmem]' with '[clock clicks]' in tcl7.5
# to make it platform independent, but you have to watch for int overflow.
  if ![info exists RNG_seed] {
    set RNG_seed [expr ([pid]+[file atime /dev/kmem])%$max]
  }
  set RNG_seed [expr ($RNG_seed*7141+54773)%$max]
  return [expr int([lindex $args 0]*($RNG_seed/double($max)))]
}

Tcl support infix expressions by default

# make vtcl suport infix expressions by default 
# i.e % 1+3 returns 4,  set a [4+3] sets a to 7
#
# Would the unknown fail anyway and does the command start with a -, +,
# or number?  if so, try it as an expression.  
# Note: you could [catch] this expr call and call unknown with it, 
# but then you'd miss out on math expression typos. 
#  Unclear which is better-- maybe make it an optional like tcl_precision?
#
# calling this proc sets up a replacement unknown proc that attempts to treat
# an expression-like string as an expression before trying the real 'unknown'
# proc handling....
proc TxAllowInfix {} {
  rename unknown tcl0_unknown
  proc unknown args {
      set cmd [lindex $args 0]
      if {[llength [info commands $cmd]]==0 && [regexp {^[0-9+\\-]} $cmd]} {
         return [expr $args]
      }
      eval tcl0_unknown $args
 }
}

Tcl debug routines

dputs is a generalised debugging echo style cmd ( triggered from the glob pattern set in the Debug variable for procnames are interested in getting dputs output firing from)

bp is a breakpoint command to put in your scripts. It interactively obtains cmds from stdin and executes them - as well as normal tcl commands the following are understood :

• '+' - go down a stack frame
• '-' - go up a stack frame
• 'C' - continue execution ( leave bp )
• '?' - display current stack frame

# set Debug variable to a glob style pattern to cause only those 
# dputs statements  in procs that match the pattern to print out 
proc dputs { args } { 
    global Debug

    if { ![info exists Debug } return
    
    set current [ expr [ info level ] -1 ]
    set caller toplevel
    catch {
	set  caller [ lindex [ info level $current ] 0]
    }
    if { [string match $Debug $caller ] } {
	puts stderr "$caller: $args 
    }
}


# dump a stack trace - place in any proc 
proc stack_dump {} {
    for {set i [info level]} {$i > 0} {incr i -1} {
        puts "Level $i: [info level $i]"
    }
}



# Show procname and calling args of current stack frame
proc bp_show {current} {
    if { $current > 0 } {
	set info [ info level $current ]
	set proc [ lindex $info 0 ]
	puts stderr "$current: Procedure $proc \
		{[info args $proc] }"
	set index 0
	foreach arg [ info args $proc ] {
	    puts stderr \
		"\t$arg = [lindex $info [incr index ]]"
	}
    } else {
	puts stderr "Top Level"
    }
}

# tcl breakpoint proc
proc bp {} {
    set max [ expr [info level] - 1 ]
    set current $max
    bp_show $current
    while {1} {
	puts -nonewline stderr "#$current: "
	gets stdin line
	while {![info complete $line ]} {
	    puts -nonewline stderr "? "
	    append line \n[gets stdin]
	}
	switch -- $line {
	      + { if {$current < $max } {
			bp_show [ incr current]
		  }
		}
	      - { if {$current > 0 } {
			bp_show [ incr current -1 ]
		  }
	        }   
	      C { puts stderr "Resuming execution"; return}
	      ? { bp_show $current }
	      default {
		  catch { uplevel #$current $line } result
		  puts stderr $result
	      }
	}
    }
}

Minimal uncgi routine

List assignment of multiple args returned from a fn

Perl: ($foo,$bar) = &some_sub;
Tcl equivalent: foreach {foo bar} [some_sub] break


# dual assignment to vars from proc return
proc lassign {l1 l2} {uplevel foreach \"$l1\" \"$l2\" break}


e.g.
proc p {} { return [list l1 l2]}
lassign {foo bar} [p]

Copying binary data to a socket

  rename unsupported0 copychannel
  fconfigure $inchannel  -translation binary
  fconfigure $outchannel -translation binary
  copychannel $inchannel $outchannel    ;# copychannel inFd outFd ?chunkSize?

Flatten list(s)

# flatten lists of lists into a single list 
# e.g. [lflatten {a { b { c { d e } f} } { g {h}}} { i {j}} }]
# gives     a b c d e f g h i j

proc lflatten args {
    regsub -all {[{}]} $args {} tmp;    # Ditch braces
    regsub -all { +} $tmp { } tmp;      # Squeeze spaces
    set fl [string trim $tmp];          # Chop leading/trailing 
    return $fl
}
# tests/examples 
#puts [lflatten {a { b { c { d e } f} } { g {h}}} { i {j}}]
#puts [lflatten { 1 2 } {a { b { c { d e } f} } { g {h}}} { i {j}}]

Obtaining status of execed program

Data arriving in stderr will make exec generate an error return. Getting actual util return status can be done by reading $errorCode (CHILDSTATUS)

Suppressing errorthrowing effects can be done by redirecting stderr.

Alternatively exec the cmd in a shell and check the return from that
as in: set exitstatus [exec sh -c {child;echo $?}]

#!/bin/env tclsh
# naive trap of errors in execed shell
# contents in stderr forces err throw

set err [catch {exec ./diag.sh} msg]
puts "diag.sh returns $err ($errorCode), message $msg"
set err [catch {exec ./err.sh} msg]
puts "err.sh returns $err ($errorCode), message $msg"

puts "...Redirect stderr ..."

# casting away errorthrowing effect of stderr output
set err [catch {exec ./diag.sh 2>@stderr } msg]
if { $err } {
    puts "diag.sh returns $err ($errorCode), message $msg" 
} else {
    puts "diag.sh returns $err (No errorCode), message $msg" 
}

set err [catch {exec ./err.sh 2>@stderr} msg]
if {$err} {
    puts "err.sh returns $err ($errorCode), message $msg" 
} else {
    puts "err.sh returns $err (No errorCode), message $msg" 
}

puts "...execing sh ..."

set err [ catch {exec sh -c {./diag.sh; echo $?} } msg]
puts "diag.sh returns $err ($errorCode), message $msg" 

set err [ catch {exec sh -c {./err.sh; echo $?} } msg]
puts "err.sh returns $err ($errorCode), message $msg" 


proc Comment {args} {}

#---------------- diag.sh
Comment {
#!/bin/sh
# diag.sh 
echo diagnostic message 1>&2
exit 0
}
# ---------------- err.sh
Comment {
#!/bin/sh
# err.sh 
echo error message 1>&2
exit 1
}