• Tk stuff has now been moved out to Bag of Tk algorithms.
• See also Donal Fellows' Tcl Archive: [1]
• 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)
  Page contents

    1-Bits in a positive int 

    ASCII map 

    A simple Arabic renderer 

    Application home 

    Array-preserving Order of Elements 

    Assertions 

    AtExit Handlers 

    Autokill 

    automatic .bak files 

    Average 

    Base 64 encode/decode 

    Cartesian product of a list of lists 

    Character frequency counts 

    Clock clicks resolution 

    configuration files 

    Compact integer list to list 

    Compact list to list 

    Country name server 

    Credit card check digit validation 

    Cross sum of a digit sequence 

    csv strings 

    Date scanning 

    Date and Time in a Handy Format 

    Debugging Aid For Production Code 

    Disk free capacity 

    do ... while 

    Drive letters 

    English number speller 

    Executable scripts 

    environment variables 

    expr 

    Files and sockets in use 

    Fraction Math 

    freeMem: Freeing memory the Tcl way!

    IEEE binary float to string conversion 

    Integer Check 

    Integer maximum 

    Integer width 

    Interrupting loops: how to introduce a "stop button" for runaway code 

    intgen: unique integer ID generator, at first call gives 1, then 2, 3, ... 

    number speller, French

    German number speller 

    time speller, German 

    money amount speller, Russian 

    getPid 

    gifBalls 

    Globbing globals 

    GPS/UTC Time Conversion Functions 

    Greeklish 

    Greatest common denominator 

    Heblish 

    hotgrep 

    integrate 

    IP address: find out your own. This beauty came from [email protected] 

    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 

    List spread to scalar vars, e.g. lspread {1 2 3} to a b {c 0} 

    List well-formedness: check a string whether it could be parsed into a list (braces balanced, whitespace after closing braces) 

    List with duplicates removed, and keeping the original order: 

    ls -l in Tcl 

    ls: make glob look more like the Unix thing 

    Mail sender (minimalist, Unix only): 

    Mail checker, even more minimalist, Unix only: 

    map - the traditional list functional that applies an operation to every member of a list. 

    Maximum and minimum Everybody writes them himself, here's mine: 

    Morse en/decoder: works both ways ASCII <-> Morse, see Bag of number/time spellers ''-  

    N-gram frequency counts, see tally: a string counter gadget 

    Namespace variables listed local names of variables as defined in a namespace: 

    NUKE: delete a file when its descriptor is closed: 

    Number commified (added culture-dependent thousands mark): 

    Option Parser: expandOpts 

    proc Instrumentation 

    proc validity in context: validProc  

    Proc name: know your own 

    Railway vehicle number validation: UIC vehicle number validator 

    Random Numbers 

    Random selection from a list 

    Roman Numbers 

    SCCS control string bypass 

    Self-test code 

    Set operations: A set of Set operations 

    Shuffle a list -- various ways of permuting a list into (pseudo-)random sequence. 

    Silly Asynchronous Event Example 

    Simple Arbitrary Precision Math Procedures -- DKF 

    Size of running Tcl process (Unix only) 

    sleep 

    Sort on String Length / Password Generator 

    String to list 

    soundex 

    Splitting strings into words 

    Stack operations on lists: lpush prepends, lpop removes first element.  

    Stack trace: just sprinkle a few of these "probes" around to see the stack at that point 

    Stats 

    String to list 

    Swap 2 values efficiently 

    subcommands: value-added switch, FREE error message ;-) 

    Tabs to spaces, and back: courtesy Jeffrey Hobbs 

    tailf tail -f piped to egrep, in pure tcl 

    try ... finally ... 

    telnet 

    timers.tcl - benchmarking/timing package 

    UIC vehicle number validator - as used on European railways 

    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 

    Split on Punctuation 

    Sample Math Programs 

1-Bits in a positive int  edit

ASCII map  edit

A simple Arabic renderer  edit

Application home  edit

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
}

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
}

% tclsh /full/path/to/script.tcl

Array-preserving Order of Elements  edit

Assertions  edit

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

AtExit Handlers  edit

Autokill  edit

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

automatic .bak files  edit

Average  edit

Base 64 encode/decode  edit

Cartesian product of a list of lists  edit

Character frequency counts  edit

Clock clicks resolution  edit

expr {-[clock clicks] + [after 1000; clock clicks]}

configuration files  edit

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
}

if {[catch {source myconfigfile} err]} {
    # some error occured
}

configfile options
setting value
setting2 {some large value}

Compact integer list to list  edit

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  edit

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  edit

Credit card check digit validation  edit

Cross sum of a digit sequence  edit

csv strings  edit

Date scanning  edit

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

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  edit

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  edit

Disk free capacity  edit

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

   {Windows 95} {
        expr [lindex [lindex [split [exec command /c dir /-c $dir] \n] end] 0]/1024
   }

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
}

do ... while  edit

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}

Drive letters  edit

mailto:[email protected]

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  edit

Executable scripts  edit

 #!/tools/bin/tclsh

 #!/bin/sh
 # the next line restarts using -*-Tcl-*-sh \
 exec tclsh "$0" ${1+"$@"}

        ::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"

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

        ::set run_dos {
                @tclsh %~f0 %*
                exit /b
        }

environment variables  edit

foreach e [lsort [array names env]] { puts "$e = $env($e)" }

expr  edit

• Importing expr functions
• expr problems with int

Files and sockets in use  edit

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  edit

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)

freeMem: Freeing memory the Tcl way! edit

IEEE binary float to string conversion  edit

Integer Check  edit

Integer maximum  edit

Integer width  edit

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  edit

intgen: unique integer ID generator, at first call gives 1, then 2, 3, ...  edit

proc intgen {{seed 0}} {
    proc intgen "{seed [incr seed]}" [info body intgen]
    set seed
} ;# RS

number speller, French edit

German number speller  edit

time speller, German  edit

money amount speller, Russian  edit

getPid  edit

gifBalls  edit

Globbing globals  edit

mailto:[email protected]

proc globalpat {args} {
    foreach pattern $args {
        set varnames [info globals $pattern]
        if {[llength $varnames] != 0} {
            uplevel 1 global $varnames
        }
    }
}

proc hello {} {
    globalpat *tcl*
    puts $tcl_patchLevel
}

% hello
8.2.2

GPS/UTC Time Conversion Functions  edit

Greeklish  edit

Greatest common denominator  edit

Heblish  edit

hotgrep  edit

integrate  edit

IP address: find out your own. This beauty came from [email protected]  edit

jpeg: Reading JPEG image dimensions  edit

Language name server, zh <-> Chinese ... see Language/Country name servers  edit

Line Counting see Counting a million lines  edit

List Frequency Counts  edit

List spread to scalar vars, e.g. lspread {1 2 3} to a b {c 0}  edit

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

news:comp.lang.tcl

proc islist {s} {
    expr ![catch {eval list $s}]
} ;# RS

set s {a; file delete -force ~}
islist $s    ;# Hope you have backups!

proc islist {s} {expr ![catch {llength $s}]} ;# DGP

List with duplicates removed, and keeping the original order:  edit

proc luniq {L} {
    # removes duplicates without sorting the input list
    set t [list]
    foreach i $L {if {[lsearch -exact $t $i]==-1} {lappend t $i}}
    return $t
} ;# RS

proc lun {L} {
    set t [list]
    foreach i $L {if { $i ni $t } { lappend t $i }}
    return $t
} ;# EE

ls -l in Tcl  edit

ls: make glob look more like the Unix thing  edit

proc ls {{fn *}} {
    lsort [glob -nocomplain $fn .$fn]
} ;#RS

Mail sender (minimalist, Unix only):  edit

proc mailto {name subj text} {
    set f [open "|mail $name" w]
    puts  $f "Subject: $subj\n\n$text"
    close $f
}

http://www.phaseit.net/claird/comp.lang.tcl/tcl-examples.html#mail

 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:  edit

proc haveMail {} {
    expr [file size /var/mail/$::env(USER)]>0
}

map - the traditional list functional that applies an operation to every member of a list.  edit

proc map {command list} {
    set res [list]
    foreach item $list {
        lappend res [uplevel 1 [concat $command [list $item]]]
    }
    set res
}

Maximum and minimum Everybody writes them himself, here's mine:  edit

Morse en/decoder: works both ways ASCII <-> Morse, see Bag of number/time spellers ''-  edit

N-gram frequency counts, see tally: a string counter gadget  edit

Namespace variables listed local names of variables as defined in a namespace:  edit

proc nsvars {ns} {
    regsub -all ::${ns}:: [info vars ${ns}::*] "" res
    set res
}  ;# RS

proc nsvars {{ns {}}} {
    map [list namespace tail] [info vars ${ns}::*]
}

NUKE: delete a file when its descriptor is closed:  edit

proc NUKE { filename fid } {
     if { ! [ llength [ file channels $fid ] ] } {
         file delete $filename
     } else {
         after 1000 "NUKE $filename $fid"
     }
}

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):  edit

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

proc commify number {
    regsub -all {\d(?=(\d{3})+($|\.))} $number {\0,}
}

Option Parser: expandOpts  edit

proc Instrumentation  edit

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

proc validity in context: validProc  edit

Proc name: know your own  edit

proc proc_name {} {
    lindex [info level -1] 0
} ;#RS

Railway vehicle number validation: UIC vehicle number validator  edit

Random Numbers  edit

Random selection from a list  edit

proc random_select list {
    lindex $list [expr int(rand()*[llength $list])]
} ;#RS

Roman Numbers  edit

SCCS control string bypass  edit

set now [clock format [clock seconds] -format %y%m%d-\x25H\x25M\x25S]

append datestring %y %m %d - %H %M %S
set now [clock format [clock seconds] -format %datestring]

Self-test code  edit

Set operations: A set of Set operations  edit

Shuffle a list -- various ways of permuting a list into (pseudo-)random sequence.  edit

Silly Asynchronous Event Example  edit

# 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

Simple Arbitrary Precision Math Procedures -- DKF  edit

Size of running Tcl process (Unix only)  edit

sleep  edit

Sort on String Length / Password Generator  edit

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  edit

soundex  edit

Splitting strings into words  edit

Stack operations on lists: lpush prepends, lpop removes first element.  edit

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

Stack trace: just sprinkle a few of these "probes" around to see the stack at that point  edit

proc probe {} {
    puts "Stack trace:"
    for {set i [expr [info level] - 1]} {$i} {incr i -1} {
        puts "  Processing '[info level $i]'."
    }
} ;# JCW

Stats  edit

String to list  edit

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 {"}

Swap 2 values efficiently  edit

foreach {a b} [list $b $a] break

lassign [list $b $a] a b

subcommands: value-added switch, FREE error message ;-)  edit

Tabs to spaces, and back: courtesy Jeffrey Hobbs  edit

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

proc tabsToSpaces {str {tabStop 8}} {
    set result {}
    set newline {}
    foreach line [split $str \n] {
        set out {}
        while {[set i [string first \t $line]] != -1} {
            set j [expr {$tabStop - ($i % $tabStop)}]
            append out [string range $line 0 [incr i -1]][format %*s $j " "]
            set line [string range $line [incr i 2] end]
        }
        append result $newline $out $line
        set newline \n
    }
    return $result
}

tailf tail -f piped to egrep, in pure tcl  edit

try ... finally ...  edit

telnet  edit

timers.tcl - benchmarking/timing package  edit

UIC vehicle number validator - as used on European railways  edit

Unit converter -- Does km/h <-> mph, DM <-> EUR, C <-> F ...  edit

URI detector for arbitrary text as a regular expression  edit

UTC -- see GPS/UTC Time Conversion Functions  edit

Validating credit card check digits  edit

Visual Studio 2003 .sln file parser  edit

Word frequency counts, see tally: a string counter gadget  edit

Plain string substitution  edit

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

set text [string map [list $item $replacewith] $text]

Split on Punctuation  edit

 (bin) 8 % break_text "A sentence, merely.  Move along."
 A { } sentence {, } merely {.  } Move { } along .

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
}

Sample Math Programs  edit

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References