Tcl Code Fragments

The following are some semi useful Tcl/TclX code fragments

Giving your procs static variables

I saw this on the Net and grabbed it without recording who initially created it (my Apologies to the author). It gives Tcl static variables within procs ( cf static in C ) and works by using a global array for the procname indexed by the variableName desired to hold the variable and mapping that onto the desired variableName within the proc.
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)]
}
Heres another one from Karl Lehenbauer (karl@NeoSoft.com) - this uses a single global Array (staticvars) referenced by procname and varname to hold the static variables. (See also TCL Language Usage Q&A)

    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

Taken from tkinspect, posted by jhobbs@cs.uoregon.edu,
# 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

An incr fn that doesn't croak if varname given does not already exist

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

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

Random number generators

This is available in TclX but heres some tcl implementations

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)
    }
}

From jhobbs@cs.uoregon.edu

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

This came from a net posting by Adam Sah.

# 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

These were originally written by Stephen Uhler and appeared in the Linux Journal.

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 :


# 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

Written by Laurent Demailly (dl@mail.dotcom.fr).

Available with comments from http://hplyot.obspm.fr/~dl/wwwtools.html

proc uncgi {buf} {
    regsub -all {\\(.)} $buf {\1} buf ;
    regsub -all {([[$"])} $buf {\\\1} buf;
    regsub -all {\+} $buf {\ } buf
    regsub -all -nocase {%([a-fA-F0-9][a-fA-F0-9])} $buf {[format %c 0x\1]} buf
    puts ($buf)
    eval return \"$buf\"
}


Hops (hops@sco.com) $ Last Modified: $Date: 1996/06/14 07:57:53 $: