Here's some "few-liner" code examples, contributed by Richard Suchenwirth, <YOUR NAME HERE>, ... . Help yourself! Add comments when you know it better! Use the Edit.. link at bottom of page for contributing! Short procs (fitting between thumb and index finger ;-) go right here, longer ones get their own pages and are linked on this page.
NEW:
Arabic from ASCII transliteration (Buckwalter) to Unicode, from abstract characters to glyphs - see A simple Arabic renderer
Array preserving order of elements: if you want to keep a history in what sequence array elements were added, have a look at Numbered arrays
Application home Find the real/exact/full path of the running script
proc app_home {} {
set old_dir [pwd]
set f $::argv0
set f_path [file dirname $f]
set f_tail [file tail $f]
cd $f_path
set f $f_tail
while {![catch {file readlink $f} result]} {
cd [file dirname $result]
set f_path [pwd] ;# pwd makes path absolute
set f_file [file tail $result]
set f [file join $f_path $f_file]
}
cd $old_dir
return $f_path
}I can not remember where I took this originally from. Sorry Andreas Wilm
Lars H: Here is another approach to the above, which also returns the list of all "home" directories (a link may point to another link, and then to yet another, etc.)
proc app_homes {} {
set res [list]
set me [info script]
catch {
while {1} {
set mydir [file dirname $me]
lappend res $mydir
set me [file join $mydir [file readlink $me]]
}; # Eventually the [file readlink] errors
}
return $res
}It could probably do with some file normalizes. However, a comparison of $::argv0 and [info script] from a portability perspective could be intereting.
SG: I'm probably just missing something (I usually do) but what does any of this do that
[pwd]
doesn't?
Lars H: Lots of things. For one, the script might have been started as
% tclsh /full/path/to/script.tcl
For another, the script might have been marked executable and was found by a search along the PATH. There is no relation between the result of pwd and the script location in either of these cases.
ASCII map No algorithm at all, but may come in handy ;-) If you're on a UNIX box, try: man ascii
proc ascii {} {return {
00 nul 01 soh 02 stx 03 etx 04 eot 05 enq 06 ack 07 bel
08 bs 09 ht 0a nl 0b vt 0c np 0d cr 0e so 0f si
10 dle 11 dc1 12 dc2 13 dc3 14 dc4 15 nak 16 syn 17 etb
18 can 19 em 1a sub 1b esc 1c fs 1d gs 1e rs 1f us
20 sp 21 ! 22 " 23 # 24 $ 25 % 26 & 27 '
28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f /
30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7
38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ?
40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G
48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O
50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W
58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _
60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g
68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o
70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w
78 x 79 y 7a z 7b { 7c | 7d } 7e ~ 7f del
}} ;#RSAssertions can be implemented in millions of ways, here is one:
proc Assert {condition} {
if {[catch {uplevel [list expr $condition]} n] || $n == "" || $n == 0} {
Puts "Assertion failed (result $n), in:"
set prefix ""
for {set i [info level]} {$i} {incr i -1} {
append prefix " "
puts "$prefix'[info level $i]'"
}
# try to call a failure handler to collect more info
if {![catch ::AssertionFailureHandler msg] && $msg != ""} {
append condition " ($msg)"
}
#error "Assertion failed: $condition"
puts "Assertion failed: $condition"
exit
}
} ;# JCWAnd of course disabled simply by overriding the above definition with "proc Assert {x} {}".
AtExit Handlers cleanup on program exit for you.
automatic .bak files automatically backs up files N levels deep to avoid overwrites
Average (arithmetic mean) of a list of numbers:
proc average L {expr ([join $L +])/[llength $L].}Note that empty lists produce a syntax error. The dot behind llength casts it to double (not dangerous here, as llength will always return a non-negative integer) -- RS
Autokill an application after a resetable delay:
proc autokill {delay {id ""}} {
if {$id != ""} {after cancel $id}
set id [after [expr int($delay * 1000 * 60)] {exit}]
proc autokill "[list delay [list id $id]]" [info body autokill]
}
autokill 30; #exit after a 30 minute delaycall it again, the same way to reset the timer. Usefull in situations where an application uses a lot of network resources, and has the potential for a user to leave it running while not in use. -- AJB
Base 64 encode/decode shamelessly stolen from Steve Uhler and Brent Welch
1-Bits in a positive int: count the number of bits of value 1 in an integer (sign-extended for negatives, so better use positives only):
proc nbits n {
set f [format %X $n]
set res 0
foreach nybble {0 1 2 3 4 5 6 7 8 9 A B C D E F} \
bits {0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4} {
set res [expr $res+$bits*[regsub -all $nybble $f - -]]
}
set res
} ;# RSMore than 30 times faster, and works for negative numbers too:
proc popcount { i } { # count the population of ones in the integer i
set pop 0
while { $i != 0 } {
incr pop
set i [expr { $i & ( $i - 1 ) }]
}
return $pop
} ;# kbk [http://titania.crd.ge.com/people/kennykb.html]This one is slower than the last, but it's a one-liner:
proc nbits2 n {expr 0[string map {0 +0 1 +1 2 +1 3 +2 4 +1 5 +2 6 +2 7 +3 8 +1 9 +2 A +2 B +3 C +2 D +3 E +3 F +4} [format %X $n]]}Character frequency counts, see tally: a string counter gadget
Compact integer list to list {1-4 6-8} => {1 2 3 4 6 7 8}
proc clist2list {clist} {
#-- clist: compact integer list w.ranges, e.g. {1-5 7 9-11}
set res {}
foreach i $clist {
if [regexp {([^-]+)-([^-]+)} $i -> from to] {
for {set j [expr $from]} {$j<=[expr $to]} {incr j} {
lappend res $j
}
} else {lappend res [expr $i]}
}
return $res
} ;#RSCompact list to list {2-4 a c-e A C-E} => {2 3 4 a c d e A C D E}
As above, this one handles a-z and A-Z as well as the proposed 0-9.
proc clist2list {{args ""}} {
if {[llength $args] != 1} {
error {wrong # args: should be "clist2list clist"}
}
set clist [lindex $args 0]
# Ensure clist is in list format, if not then make it so.
if {[catch {llength $clist}]} {set clist [split $clist]}
array set map [list a 1 b 2 c 3 d 4 e 5 \
f 6 g 7 h 8 i 9 j 10 \
k 11 l 12 m 13 n 14 o 15 \
p 16 q 17 r 18 s 19 t 20 \
u 21 v 22 w 23 x 24 y 25 \
z 26 \
\
1 a 2 b 3 c 4 d 5 e \
6 f 7 g 8 h 9 i 10 j \
11 k 12 l 13 m 14 n 15 o \
16 p 17 q 18 r 19 s 20 t \
21 u 22 v 23 w 24 x 25 y \
26 z]
set re_syntax {^(([0-9]+-[0-9]+)|([A-Z]-[A-Z])|([a-z]-[a-z]))$}
set res {}
foreach i $clist {
if {[regexp $re_syntax $i -> range a b c]} {
set range [split $range -]
set start [lindex $range 0]
set stop [lindex $range 1]
switch -- [expr {($a!="")?1:($b!="")?2:($c!="")?3:4}] {
1 {
for {set j $start} {$j <= $stop} {incr j} {
lappend res $j
}
}
2 {
set j $map([string tolower $start])
for {} {$j <= $map([string tolower $stop])} {incr j} {
lappend res [string toupper $map($j)]
}
}
3 {
for {set j $map($start)} {$j <= $map($stop)} {incr j} {
lappend res $map($j)
}
}
}
} else {lappend res $i}
}; return $res
} ;# Carl M. Gregory, MC_8 -- http://mc.purehype.net/Country name server, CH <-> Switzerland.. see Language/Country name servers
Credit card check digit validation: see Validating credit card check digits
Cross sum of a digit sequence, e.g. an integer:
proc cross_sum {s} {expr [join [split $s ""] +]} ;# RSBeautiful shimmering: s goes from string to list to string to int ;-)
csv strings: comma-separated values, as exported e.g. by Excel, see Parsing csv strings
Date and time in a handy format like 22.07.99,19:59:00
proc date,time {{when ""}} {
if {$when == ""} {set when [clock seconds]}
clock format $when -format "%d.%m.%y,%H:%M:%S"
} ;#RSDate scanning: clock scan older versions (pre 8.3?) did not handle the frequent (ISO-standardized) format YYYY-MM-DD hh:mm:ss. Here's a workaround by Hume Smith to be used in the place of clock scan for such cases:
proc yyyy-mm-dd {dtstring} {
set time {} ;# this allows pure dates without time
scan $dtstring %d-%d-%d%s year month day time
clock scan "$month/$day/$year $time"
} ;# RSand another by Bruce Gingery:
proc YYYYMMDD2MDY {dtstring} {
set patt {^[1-2][0-9]([0-9][0-9])-([0-9][0-9]?)-([0-9][0-9]?)}
set subs {\2/\3/\1}
regsub $patt $dtstring $subs dtstring
return $dtstring
# or return [clock scan $dtstring]
}Debugging Aid For Production Code -PSE
Disk free capacity, in Kilobytes:
proc df-k {{dir .}} {
switch $::tcl_platform(os) {
FreeBSD -
Linux -
OSF1 -
SunOS {
# Use end-2 instead of 3 because long mountpoints can
# make the output to appear in two lines. There is df -k -P
# to avoid this, but -P is Linux specific afaict
lindex [lindex [split [exec df -k $dir] \n] end] end-2
}
HP-UX {lindex [lindex [split [exec bdf $dir] \n] end] 3}
{Windows NT} {
expr [lindex [lindex [split [exec cmd /c dir /-c $dir] \n] end] 0]/1024
# CL notes that, someday when we want a bit more
# sophistication in this region, we can try
# something like
# secpercluster,bytespersector, \
# freeclusters,noclusters = \
# win32api.GetDiskFreeSpace(drive)
# Then multiply long(freeclusters), secpercluster,
# and bytespersector to get a total number of
# effective free bytes for the drive.
# CL further notes that
#http://developer.apple.com/techpubs/mac/Files/Files-96.html
# explains use of PBHGetVInfo() to do something analogous
# for MacOS.
}
default {error "don't know how to df-k on $::tcl_platform(os)"}
}
} ;#RSfor Win9x replace cmd with command. Note that W98(SE)? may report as Windows 95. So,
{Windows 95} {
expr [lindex [lindex [split [exec command /c dir /-c $dir] \n] end] 0]/1024
}Every time df comes up in clt, I think I should write one that works for us *poor souls* who are stuck in the world of win9x. So the other night...:
proc free_win { } {
set res [eval exec [auto_execok dir]]
set var [expr [llength $res] -3]
set free_space [lrange $res $var end]
return $free_space
}This works on win95, 98 and NT, with tcl/tk 8.0 through 8.4a2. If anybody tests it with win2000 or ME, please let us know the result.
so 04/20/01
do ... while loop structure. By Morten Skaarup Jensen
proc do {cmds while expr} {
uplevel $cmds
uplevel "while [list $expr] [list $cmds]"
}
# Example of use
set x 0
do {
puts $x
incr $x
} while {$x < 10}This doesn't work 100% with breaks. Catch might be the best way to improve this. See also do...until in Tcl
Drive letters on Windows -- "file volumes" lists drives even if there's no medium in it. mailto:[email protected] contributed this code to list mapped and existing drives:
proc drives {} {
foreach drive \
[list a b c d e f g h i j k l m n o p q r s t u v x y z] {
if {[catch {file stat ${drive}: dummy}] == 0} {
lappend drives $drive
}
}
return $drives
}English number speller, e.g. en:num 29 => twenty-nine, see Bag of number/time spellers
Event loop magic can your scripting language do this?
#!/bin/sh
# the next line restarts using -*-Tcl-*-sh \
exec tclsh "$0" ${1+"$@"}
;## initialise our trigger variable
set foo {}
;## a proc to call when the trigger variable is written
proc bye {args} { exit }
;## some code to push into the event loop for 0.5 sec
;## that produces visible output, and writes the trigger var
after 500 {
puts "what a question!"
set foo {}
}
;## some other code that gets pushed into the loop for 0.2 sec
after 200 {
puts "where did I come from?"
}
;## some code that is executed immediately
puts "and then he asked:"
;## set a trace on "foo", so that when it is written the
;## procedure "bye" is called
trace variable foo w bye
;## initiate an event loop (this is what "wish" does)
vwait enter-mainloop(DKF: And this is suppposed to be a good feature of Tcl? Hmmm...)
Executable scripts: Tcl scripts with initial magic can be called directly from a shell prompt. In UNIX, you can specify the path to tclsh (or wish, as you wish) in a special comment line, e.g.
#!/tools/bin/tclsh
but this requires adaptation to the local situation. More flexible is the following, which finds the way itself:
#!/bin/sh
# the next line restarts using -*-Tcl-*-sh \
exec tclsh "$0" ${1+"$@"}Tom Tromey explains the ${1+"$@"} bit in exec magic
The -*- stuff instructs emacs to treat this file in Tcl mode. In both cases, do a chmod +x filename for real availability.
For Win95, Rolf Schroedter reports the following to work: file foo.bat:
::set run_dos { ;# run tcl-script from BAT-file
tclsh80 %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
exit
}
puts "Tcl $tcl_patchLevel"Small addition: This has at least on NT the problem, that, when started from a CMD.EXE window that this window gets closed on the "exit" call. I cannot find any command to just terminate the running script, so I use:
::set run_dos { ;# run tcl-script from BAT-file
tclsh80 %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
goto EOF
}
# your TCL code goes here
# ...
::set run_dos \
:EOF
Might get a problem if ":EOF" is a valid Proc in your program and gets called in the main program, though. - Michael Teske
This works for me on NT:
::set run_dos {
@tclsh %~f0 %*
exit /b
}It has the added advantage that all command line arguments are given to tclsh ("%*") and that the tclsh gets the full path of the file to start ("%~f0") - Klaus Marius Hansen - See also DOS BAT magic
expandOpts Option Parser
expr: see Importing expr functions - expr problems with int
File mode, Unix style returns something like drwxr--r--
proc file_mode fn {
file stat $fn t
if [file isdirectory $fn] {
set prefix "d"
} else {
set prefix "-"
}
set s [format %03o [expr $t(mode)%512]]
foreach i { 0 1 2 3 4 5 6 7} \
j {--- --x -w- -wx r-- r-x rw- rwx} {
regsub -all $i $s $j s
}
return $prefix$s
} ;#RSFile line termination CR and/or LF? Donal Fellows shows the way:
proc file_lineterm {filename} {
set fd1 [open $filename r]
set fd2 [open $filename r];# Avoids most synch problems...
fconfigure $fd2 -translation binary
set EOLidx [string length [gets $fd1]]
close $fd1
read $fd2 $EOLidx
set EOLchars [read $fd2 2]
close $fd2
if {[string equal $EOLchars "\r\n"]} {
return "crlf" ;# DOS/Windows
} elseif {[string equal [string index $EOLchars 0] "\r"]} {
return "cr" ;# Mac
} elseif {[string equal [string index $EOLchars 0] "\n"]} {
return "lf" ;# Unix
} else {
return "unknown"
}
}Lars H, 27 Feb 2003: Doesn't that -- rather than determining what is the line terminator in the specified file -- determine what Tcl considers to be the line terminator? Answering myself 9 Sep 2004: Yes it does, but the default for Tcl reading files is to treat all of lf, cr, and crlf as a line termination, so you really get the wanted information about which one of those three it is in this file.
File reader: takes a filename, returns the lines of that file as a list. Trivial algorithm, but note the "whitespace sugar": mentions of a variable are vertically aligned to indicate data flow ;-)
proc file_lines {fn} {
set f [open $fn r]
set t [read $f [file size $fn]]
close $f
split $t \n
} ;#RSFiles and sockets in use, by Phil Ehrens <[email protected]> Sorry, UNIX only:
proc countFilehandles {{limit 1024}} {
set i 0; set socks {}; set files {}
while {$i < $limit} {
if ![catch {tell sock$i}] {lappend socks sock$i}
if ![catch {tell file$i}] {lappend files file$i}
incr i
}
return [list $socks $files]
}For Tcl 8.4 the file channels builtin command does this.
Fraction math 2.75 <-> 2-3/4. Not exact, resolution can be specified (default 1/8)
proc fracn2num {args} {
if ![regexp {(([0-9]+)[ -])?([0-9]+)/([0-9]+)} $args -> - int num den] {
return $args
}
expr $int+double($num)/$den
}
proc num2fracn {n {r 8}} {
if [set in [expr int($n)]]==$n {return $n}
if $in {set res $in-} else {set res {}}
return $res[join [simplify [expr int(round(($n-$in)*$r))] $r] /]
}
proc simplify {p q} {
set g [gcd $p $q]
list [expr $p/$g] [expr $q/$g]
} ;#RS (frac2num handling for things like '2 3/4' added by PSE)But see Fraction Math -- kbk [L2 ]
Freeing memory the Tcl way! Permits evaluation of code in a manner which does NOT cause the interpreter to permanently allocate heaps of heap. freeMem
French number speller fr:num 99 => quatrevingt dix-neuf, see Bag of number/time spellers
German number speller, see Bag of number/time spellers
German time speller: converts exact HH:MM times to fuzzy colloquial wording, optional Northern (viertel vor vier) or Southern style (dreiviertel vier) ;-) see Bag of number/time spellers
Globbing globals: Want to import several globals in one go, with glob wildcards (similar to the public statement in VB)? This comes from David Cuthbert (mailto:[email protected] ):
proc globalpat {args} {
foreach pattern $args {
set varnames [info globals $pattern]
if {[llength $varnames] != 0} {
uplevel 1 global $varnames
}
}
}To use:
proc hello {} {
globalpat *tcl*
puts $tcl_patchLevel
}
% hello
8.2.2GPS/UTC Time Conversion Functions
Greeklish turns a strict ASCII transliteration into Greek Unicodes. Heblish turns a strict ASCII transliteration into Hebrew Unicodes.
hotgrep it beats as it sweeps as it cleans!
Greatest common denominator now on its own page
IEEE binary float to string conversion
Integer, see whether variable has an i. value:
proc is_int x {expr {![catch {incr x 0}]}}
proc is_no_int x {catch {incr x 0}}Since Tcl 8.1.1, the built-in string is int does the same for a value.
Integer maximum (MAXINT): determine biggest positive signed integer (by Jeffrey Hobbs):
proc largest_int {} {
set int 1
set exp 7; # assume we get at least 8 bits
while {$int > 0} { set int [expr {1 << [incr exp]}] }
expr {$int-1}
}Integer width in bits (by Jeffrey Hobbs):
proc int_bits {} {
set int 1
set exp 7; # assume we get at least 8 bits
while {$int > 0} { set int [expr {1 << [incr exp]}] }
# pop up one more, since we start at 0
incr exp
}Interrupting loops: how to introduce a "stop button" for runaway code
intgen: unique integer ID generator, at first call gives 1, then 2, 3, ... Note how the proc rewrites its own seed default, so no global variable is needed:
proc intgen {{seed 0}} {
proc intgen "{seed [incr seed]}" [info body intgen]
set seed
} ;# RSIP address: find out your own. This beauty came from [email protected] (note that xxx should be the name of a procedure which never gets called, so need not exist ;-):
[ip:adr used to be here.]
Many Tcl programmers wonder how to find my own IP address.
JPEG, see Reading JPEG image dimensions
Language name server, zh <-> Chinese ... see Language/Country name servers
Line Counting see Counting a million lines
List Frequency Counts see Counting Elements in a List
List spread to scalar vars, e.g. lspread {1 2 3} to a b {c 0}
proc lspread {list "to" args} {
foreach a $args v $list {
upvar [lindex $a 0] var ;# name maybe in list with default
if {$v==""} {set var [lindex $a 1]} else {set var $v}
}
} ;#RSList well-formedness: check a string whether it could be parsed into a list (braces balanced, whitespace after closing braces) - joint effort by Bob Techentin and Donald Porter in news:comp.lang.tcl :
proc islist {s} {expr ![catch {eval list $s}]} ;# RSHmmm... let's think twice about this one. We want to test the list well-formedness of an unknown string, so we probably don't know much about $s. It's dangerous to [eval] something you don't know. Consider this:
set s {a; file delete -force ~}
islist $s ;# Hope you have backups!Try this instead:
proc islist {s} {expr ![catch {llength $s}]} ;# DGPIndeed. The former returns bad values for most things containing '$', or [, ] etc. The latter does what you want.
List with duplicates removed, and keeping the original order:
proc luniq {L} {
# removes duplicates without sorting the input list
set t {}
foreach i $L {if {[lsearch -exact $t $i]==-1} {lappend t $i}}
return $t
} ;# RSls: make glob look more like the Unix thing
proc ls {{fn *}} {lsort [glob -nocomplain $fn .$fn]} ;#RSAlso see ls -l in Tcl....
Mail sender (minimalist, Unix only):
proc mailto {name subj text} {
set f [open "|mail $name" w]
puts $f "Subject: $subj\n\n$text"
close $f
}Cf. http://www.phaseit.net/claird/comp.lang.tcl/tcl-examples.html#mail
using tcllib: PT
package require mime
package require smtp
set tok [mime::initialize -canonical text/plain -string "Hello, World!"]
smtp::sendmessage $tok \
-header {From "[email protected]"} \
-header {To "You <[email protected]>"} \
-header {Subject "Simple Tcllib mailing."}
mime::finalize $tok
Mail checker, even more minimalist, Unix only:
proc haveMail {} {expr [file size /var/mail/$::env(USER)]>0}yet another Tcl mail handler! (for UNIX)
map - the traditional list functional that applies an operation to every member of a list.
proc map {command list} {
set res [list]
foreach item $list {
lappend res [uplevel 1 [concat $command [list $item]]]
}
set res
}See also Steps towards functional programming for related discussions.
Maximum and minimum Everybody writes them himself, here's mine:
proc max {a args} {foreach i $args {if {$i>$a} {set a $i}};return $a}
proc min {a args} {foreach i $args {if {$i<$a} {set a $i}};return $a}Works with whatever < and > can compare (strings included). Or how about (float numbers only):
proc max args {lindex [lsort -real $args] end}
proc min args {lindex [lsort -real $args] 0}Or, use -dictionary to handle strings, ints, real.... and also allow to be called with a single list arg (FYI, it's actually a bit faster to use the sort method)
proc min args {
if {[llength $args] == 1} {set args [lindex $args 0]}
lindex [lsort -dict $args] 0
}
proc max args {
if {[llength $args] == 1} {set args [lindex $args 0]}
lindex [lsort -dict $args] end
}RS: ... only that you get lsort results like
{-1 -5 -10 0 5 10}if you use the -dict mode of lsort. Numeric max/min should rather use -integer or -float. Max/min of strings must be left to dedicated procs, if ever needed.
Morse en/decoder: works both ways ASCII <-> Morse, see Bag of number/time spellers - yah, well, it has to go somewhere... JC
N-gram frequency counts, see tally: a string counter gadget
Namespace variables listed local names of variables as defined in a namespace:
proc nsvars {ns} {
regsub -all ::${ns}:: [info vars ${ns}::*] "" res
set res
} ;# RSalternatively (requires map operator from elsewhere on this page) - DKF
proc nsvars {{ns {}}} {
map [list namespace tail] [info vars ${ns}::*]
}NUKE delete a file when its descriptor is closed:
proc NUKE { filename fid } {
if { ! [ llength [ file channels $fid ] ] } {
file delete $filename
} else {
after 1000 "NUKE $filename $fid"
}
}DKF - Alternatively, rewrite the close and exit commands...
rename close orig_close_NUKE
rename exit orig_exit_NUKE
proc close {fid} {
global NUKE errorInfo errorCode
set code [catch {orig_close_NUKE $fid} msg]
set ei $errorInfo
set ec $errorCode
if {[info exist NUKE($fid)]} {
file delete $NUKE($fid)
unset NUKE($fid)
}
return -code $code -errorinfo $ei -errorcode $ec $msg
}
proc exit {{code 0}} {
global NUKE
foreach fid [array names NUKE] {catch {close $fid}}
orig_exit_NUKE $code
}
proc NUKE {filename fid} {
global NUKE
set NUKE($fid) $filename
}
proc tmpfile {{tmpdir /tmp}} {
global SEQID; if {![info exist SEQID]} {set SEQID 0}
set basename [file rootname [file tail $::argv0]]
set filename [file join $tmpdir ${basename}.[pid].[incr SEQID].tmp]
set fid [open $filename w+]
NUKE $filename $fid
return $fid
}Number commified (added culture-dependent thousands mark):
proc number_commify {n {sign ,}} {
# structure a decimal like 123,456.78 123'456.78, or 123.456,78
if {$sign=="."} {regsub {[.]} $n "," n}
set trg "\\1$sign\\2"
while {[regsub {^ *([-+]?[0-9]+)([0-9][0-9][0-9])} $n $trg n]} {}
return $n
} ;# added " *" to regexp, so leading blanks as from format work - RSA one-liner alternative by Peter Spjuth (in the Tcl chatroom, 2004-10-05) uses modern regexp features:
proc commify number {regsub -all {\d(?=(\d{3})+($|\.))} $number {\0,}}Option Parser expandOpts
proc Instrumentation
You can add code to every procedure in your Tcl application by redefining the proc command to include special code. Then each proc definition will include your code. This is commonly done for debuggers and profilers. For example, if you wanted to count each time your procedures are called, you could include code like this example, courtesy of Bryan Oakly on comp.lang.tcl.
rename proc _proc
_proc proc {name arglist body} {
set body "incr ::proc_counter($name)\n$body"
set ::proc_counter($name) 0
uplevel [list _proc $name $arglist $body]
}See also Printing proc sequence.
proc validity in context: returns 1 if the procedure name or wildcard pattern exists in the current context (including all child namespaces), returns 0 if it does not. Sort of a info commands for heavy namespace users. validProc
Proc name, know your own: this one-liner wraps introspection. Useful for generated widget handlers, whose name is like the widget pathname, so they know what their widget is called:
proc proc_name {} {lindex [info level -1] 0} ;#RSRailway vehicle number validation, see UIC vehicle number validator
Random numbers: Of course, since 8.0 just say
expr {rand()}. Jeffrey Hobbs has this substitute for pre-8.0 Tcl:
set _ran [clock seconds]
proc random {range} {
global _ran
set _ran [expr ($_ran * 9301 + 49297) % 233280]
return [expr int($range * ($_ran / double(233280)))]
}Pass in an int and it returns a number (0..int). Also, the Wiki page on "rand" has more on the subject.
Random selection from a list
proc random_select list {
lindex $list [expr int(rand()*[llength $list])]
} ;#RSRoman numbers from integer, and Roman numbers parsed into integer, see Bag of number/time spellers
SCCS control string bypass: When you ckeck in a file with SCCS, certain strings in the file are replaced, e.g. %H% with the current date, %M% with the current filename. This can cause problems if your code contains e.g.
set now [clock format [clock seconds] -format %y%m%d-%H%M%S]
but you can hide percent signs by replacing them with the equivalent \x25, so SCCS doesn't see them but the Tcl parser does (RS):
set now [clock format [clock seconds] -format %y%m%d-\x25H\x25M\x25S]
Here's my method - use append to build up the string:
append datestring %y %m %d - %H %M %S set now [clock format [clock seconds] -format %datestring]
Marty Backe
Self-test code: In a Tcl script that is sourced by other files, it's nice to have some code for standalone testing (feeding only this file to a tclsh/wish, double-clicking on Windows, where you even get a free console for seeing stdout ;-). Just brace the self-test code with
ifstandalone {#test what you want...}
proc ifstandalone body {
global argv0
if { [info exists argv0] && \
![string compare [file tail [info script]] [file tail $argv0]] } {
catch {console show}
uplevel $body
}
}Set operations, see A set of Set operations
Shuffle a list -- various ways of permuting a list into (pseudo-)random sequence.
Simple Arbitrary Precision Math Procedures - DKF
Size of running Tcl process (Unix only) now on a page of its own...
Sort on String Length / Password Generator
proc {lengthCompare} {w1 w2} {
set sl1 [string length $w1]
set sl2 [string length $w2]
if {$sl1 > $sl2} {
return 1
} elseif {$sl1 == $sl2} {
return 0
} else {
return -1
}
}
set data {asdf asdfasdf asdfa asd asdfasd}
# The following will sort the command by String Length
set data [lsort -command lengthCompare $data]
# More info -
# The following makes a password out of the data by using
# the word alone if it is 5 chars or more, (eg asdfasd)
# and by finding a match for it if it is less (eg asd-asdf)
# than 5 chars. The password can be max of 8 chars in
# this example.
# This was used on a stripped-down version of the words
# file for the UNIX spell checker to generate random
# passwords.
set datalength [llength $data]
set word1 [lindex $data [expr {int([expr {rand()*$datalength}])}]]
set w1l [string length $word1]
if {$w1l < 5} {
set pos [expr {int([expr {rand()*$datalength}])}]
# This speedily decrements the random number generated
# until the size is small enough to fit in an 8 char
# field.
while {[expr {8-$w1l-[string length [lindex $data $pos]]}] < 1} {
set pos [expr {int([expr {rand()*$pos}])}]
}
set word2 [lindex $data $pos]
append word1 "-$word2"
set word1 "$word1"
}
# Output the password
puts "${word1}\n"Stack operations on lists: lpush prepends, lpop removes first element. lpop and lappend make a FIFO queue.
proc lpush {_list what} {
upvar $_list L
if ![info exists L] {set L {}}
set L [concat [list $what] $L]
}
proc lpop {_list} {
upvar $_list L
if ![info exists L] {return ""}
set t [lindex $L 0]
set L [lrange $L 1 end]
return $t
} ;#RSalso see: yet another stack package and the Chart of proposed list functionality
Stack trace: just sprinkle a few of these "probes" around to see the stack at that point (shamelessly swiped from Cameron Laird):
proc probe {} {
puts "Stack trace:"
for {set i [expr [info level] - 1]} {$i} {incr i -1} {
puts " Processing '[info level $i]'."
}
} ;# JCWFor more on this subject, see "Printing proc sequence".
String to list: [split $s] alone operates on each instance of the splitchar (default:space), so sequences of spaces will produce empty list elements. [eval list $s] collapses whitespace sequences in one, but errors on unbalanced braces etc. The following proc should join the best of both worlds:
proc string2list s {
if [catch {eval list $s} res] {
set res [list]
foreach i [split $s] {
if {$i!=""} {lappend res $i}
}
}
set res
} ;#RS
% string2list {a b c d}
a b c d
% string2list "a b c {"
a b c \{
% string2list {unbalanced "}
unbalanced {"}Note that this suffers from the same dangers as explained in the List well-formedness test above. Modifications for safety are left as an exercise for the reader (or the next Wiki visitor). You have been warned. - DGP
EE: This seems as good a place as any to ask this question... Is there any effective difference, in general, between catch {eval command $args} and catch [linsert $args 0 command] ?
Yes: The latter is more efficient. See pure list and many ways to eval for discussion.
DGP: Yes, see those pages, but efficiency differences are not the main point. Those two examples will process newlines in the arguments differently. Newlines are significant to eval but not necessarily preserved by list-processing commands.
subcommands -- value-added switch, FREE error message ;-)
Tabs to spaces, and back: courtesy Jeffrey Hobbs
# untabify --
# removes tabs from a string, replacing with appropriate number of
# spaces. Arguments:
# str input string
# tablen tab length, defaults to 8
# Returns:
# string sans tabs
#
proc untabify {str {tablen 8}} {
set out {}
while {[set i [string first "\t" $str]] != -1} {
set j [expr {$tablen-($i%$tablen)}]
append out [string range $str 0 [incr i -1]][format %*s $j { }]
set str [string range $str [incr i 2] end]
}
return $out$str
}
# tabify --
# converts excess spaces to tab chars. Arguments:
# str input string
# tablen tab length, defaults to 8
# Returns:
# string with tabs replacing excess space where appropriate
#
proc tabify {str {tablen 8}} {
## We must first untabify so that \t is not interpreted to be 1 char
set str [untabify $str]
set out {}
while {[set i [string first { } $str]] != -1} {
## Align i to the upper tablen boundary
set i [expr {$i+$tablen-($i%$tablen)-1}]
set s [string range $str 0 $i]
if {[string match {* } $s]} {
append out [string trimright $s { }]\t
} else {
append out $s
}
set str [string range $str [incr i] end]
}
return $out$str
}tailf tail -f piped to egrep, in pure tcl
telnet - client and server... but not exactly as in RFC854.
timers.tcl - benchmarking/timing package
UIC vehicle number validator - as used on European railways
Unicode char to \u sequence: simple, but handy when examining Unicode output:
proc u2x {u} {scan $u %c t; format "\\u%04.4X" $t} ;#RSUnit converter -- Does km/h <-> mph, DM <-> EUR, C <-> F ...
URI detector for arbitrary text as a regular expression
UTC -- see GPS/UTC Time Conversion Functions
Validating credit card check digits
Visual Studio 2003 .sln file parser
Word frequency counts, see tally: a string counter gadget
Plain string substitution Prior to version 8.1.1, the only string substitution facility in the Tcl core uses regular expressions, which for substituting special text can be a pain. Here's a procedure to do a plain substition (with no extra features). See "string map" in newer versions.
proc plainsub {text item replacewith} {
set len [expr [string length $item]-1]
while {[set pos [string first $item $text]] != -1} {
set text [string replace $text $pos [expr $pos+$len] $replacewith]
}
return $text
} ;#FWRS What's bad with the following?
set text [string map [list $item $replacewith] $text]
FW Nothing, I'm pretty much just starting out coding, for a second there I thought I'd made something useful ;) CL interrupts: Nah, the correct answer is that Richard's set text ..." is bad because "string map ..." only appeared with 8.1.1.
As bad things go, that's only a tiny badness.
configuration files
this proc can be added to an application
proc configfile {name} {
global $name
set data [read [set fh [open [info script] r]]]
close $fh
array set $name $data
catch {unset ${name}(configfile) ${name}(#)}
return -code return
}and then at the top of a file you wish to be loaded as a configuration file simply add
configfile var
of course you must load the file
if {[catch {source myconfigfile} err]} {
# some error occured
}the contents of the file then end up in global variable var
an example file:
configfile options
setting value
setting2 {some large value}this was developed for Easy User Configurable Menus
FW: This procedure breaks a line of text into an alternating list of words and punctuation. For example:
(bin) 8 % break_text "A sentence, merely. Move along."
A { } sentence {, } merely {. } Move { } along .This would be used for most any language processing task, where you would break a sentence into words, perform operations on the words, then put it back together. Here it is:
proc break_text {text {splitchars {, .";!:}}} {
set regexp "\[\\[join [split $splitchars ""] \\]\]+|$" ;# Escape all the split characters so brackets, ^ etc. will be accepted.
set wp [list]
set pos 0
for {set pos 0} {$pos < [string length $text] && [regexp -indices -start $pos $regexp $text matches]} {set pos [expr {[lindex $matches 1] + 1}]} {
lappend wp \
[string range $text $pos [expr {[lindex $matches 0] - 1}]] \
[eval string range [list $text] $matches]
}
return $wp
}update: Now you can break by a character set of your choice by the optional second argument. And returns a flat list rather than a list of lists, for better use by foreach, etc.
See also: Sample Math Programs