Here's some "few-liner" code examples, contributed by [Richard Suchenwirth], , ... . 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. * Tk stuff has now been moved out to [Bag of Tk algorithms]. * See also [Donal Fellows]' Tcl Archive: [http://www.man.ac.uk/~zzcgudf/tcl/] * Also moved some of Richard's language-related stuff into [Bag of number/time spellers] (JC) * You may also be interested in the [Example Scripts Everybody Should Have] (DKF) and [Regular Expression Examples] (RWT) * See also [Braintwisters] for more esoteric snippets ([FW]) <> ** 1-Bits in a positive int ** See [Bit Twiddling] ** ASCII map ** see [Additional string functions] ** [A simple Arabic renderer] ** '''Arabic''' from ASCII transliteration (Buckwalter) to Unicode, from abstract characters to glyphs ** 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 normalize]s. However, a comparison of $::argv0 and [[info script]] from a portability perspective could be interesting. [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 ======none % 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. ** 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] ** Assertions ** 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 } } ;# JCW ====== And of course disabled simply by overriding the above definition with "proc Assert {x} {}". ** [AtExit Handlers] ** cleanup on program exit for you. ** Autokill ** kill an application after a resettable 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 delay ====== call it again, the same way to reset the timer. Useful 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] ** [automatic .bak files] ** automatically backs up files N levels deep to avoid overwrites ** Average ** See [Additional math functions] ** [Base 64 encode/decode] ** '''shamelessly stolen from Steve Uhler and Brent Welch''' ** [Cartesian product of a list of lists] ** ** Character frequency counts ** see [tally: a string counter gadget] ** Clock clicks resolution ** Unlike most time-related things handled by Tcl, the unit of the value returned by [clock clicks] is documented to be platform-dependent (even though the microsecond is very frequent), so it might be good to check roughly how many clicks there are in a second. The following one-liner will do that: ====== expr {-[clock clicks] + [after 1000; clock clicks]} ====== ** 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: ======none configfile options setting value setting2 {some large value} ====== this was developed for [Easy User Configurable Menus] ** 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 } ;#RS ====== ** Compact 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 ** see [Additional math functions] ** csv strings ** comma-separated values, as exported e.g. by Excel, see [Parsing csv strings] ** Date 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" } ;# RS ====== and 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] } ====== ** 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" } ;#RS ====== ** [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)"} } } ;#RS ====== for 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 ** See also [do...until in Tcl] do ... while loop structure, as in C 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. ** Drive letters ** on Windows -- "file volumes" lists drives even if there's no medium in it. mailto:Petteri.Kettunen@picker.fi 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] ** 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] ** expr ** * [Importing expr functions] * [expr problems with int] ** File 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 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 } ;#RS ====== ** 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 } ;#RS ====== ** Files and sockets in use ** For Tcl 8.4 the '''file channels''' builtin command does this. by [Phil Ehrens] 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] } ====== ** [Fraction Math] ** See [Fraction Math] -- kbk [http://titania.crd.ge.com/people/kennykb.html] 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) ====== offers some advances on the ''Fraction math' section. ** [freeMem%|%freeMem: Freeing memory the Tcl way!%|%]** Permits evaluation of code in a manner which does NOT cause the interpreter to permanently allocate heaps of heap. ** [IEEE binary float to string conversion] ** ** Integer Check ** See [Additional math functions] ** Integer maximum ** see [Additional math functions] ** Integer width ** in bits (by [Jeffrey Hobbs]): ====== proc int_bits {} { set int 1 set exp 8; # Assuming a minimum of 8 bits while {$int > 0} { set int [expr {1 << [incr exp 8]}] } # Increment in steps of 8 as integer length format is 8 bits, 16 bits ,32 bits, .... return $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 } ;# RS ====== ** number speller ,French** fr:num 99 => quatrevingt dix-neuf see [Bag of number/time spellers] ** German number speller ** see [Bag of number/time spellers] ** time speller ,German ** 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] ** money amount speller ,Russian ** see [Bag of number/time spellers] ** [getPid] ** map pids to prog names and vice-versa ** [gifBalls] ** ** 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:dacut@kanga.org): ====== 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.2 ====== ** [GPS/UTC Time Conversion Functions] ** Tcl implementation of Simpson's Rule numerical integration. ** [Greeklish] ** turns a strict ASCII transliteration into Greek Unicodes ** [Greatest common denominator] ** now on its own page ** [Heblish] ** turns a strict ASCII transliteration into Hebrew Unicodes. ** [hotgrep] ** it beats as it sweeps as it cleans! ** [integrate] ** ** IP address: find out your own. This beauty came from mads@electronicfarm.com ** (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: [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} } } ;#RS ====== ** List 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}] } ;# RS ====== Hmmm... 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}]} ;# DGP ====== Indeed. 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 } ;# RS ====== ====== proc lun {L} { set t {} foreach i $L {if { $i ni $t } { lappend t $i }} return $t } ;# EE ====== ** [ls -l in Tcl] ** ** ls: make glob look more like the Unix thing ** ====== proc ls {{fn *}} { lsort [glob -nocomplain $fn .$fn] } ;#RS ====== Also 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 "myself@here.com"} \ -header {To "You "} \ -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: ** see [Additional math functions] ** 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 } ;# RS ====== alternatively (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 - RS ====== A 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,} } ====== See also [Human readable file size formatting] ** 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: [validProc] ** 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. ** 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 } ;#RS ====== ** Railway vehicle number validation: [UIC vehicle number validator] ** ** Random Numbers ** see [Additional math functions] ** Random selection from a list ** ====== proc random_select list { lindex $list [expr int(rand()*[llength $list])] } ;#RS ====== ** Roman Numbers ** [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 ** evaluated only when executed, not when sourced 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: [A set of Set operations] ** ** [Shuffle a list] -- various ways of permuting a list into (pseudo-)random sequence. ** ** Silly Asynchronous Event Example ** ====== # 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 supposed to be a ''good'' feature of Tcl? Hmmm...)'' ** Simple [Arbitrary Precision Math Procedures] -- [DKF] ** ** [Size of running Tcl process] (Unix only) ** ** [sleep] ** unix-like ** 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" ====== ** String to list ** collapsing splitchar sequences ** [soundex] ** ** [Splitting strings into words] ** ** 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 } ;#RS ====== also 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]'." } } ;# JCW ====== For more on this subject, see "[Printing proc sequence]". ** [Stats] ** simple statistical functions (mean, stddev, cov) ** 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. ** Swap 2 values efficiently ** Swaps value of a with b without overhead of copying to a temporary variable: ====== foreach {a b} [list $b $a] break ====== Works for a and b as numbers, strings and lists but not arrays. [AMG]: Here's a faster method that works using Tcl 8.5+. ====== lassign [list $b $a] a b ====== On my machine, [[[lassign]]] takes 3.2239 microseconds per iteration, whereas [[[foreach]]] takes 8.562 microseconds per iteration. ** [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 ** ** [try ... finally ...] ** ** [telnet] ** Sort of 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 } ;#RS ====== ** [Unit 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 } ;#FW ====== [RS] 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. ** Split on Punctuation ** [FW]: 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 {, .";!:}}} { # Escape all the split characters so brackets, ^ etc. will be accepted. set regexp "\[\\[join [split $splitchars ""] \\]\]+|$" 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.'' ** [Sample Math Programs] ** <> Algorithm | Example | Arts and crafts of Tcl-Tk programming