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

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

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

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

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}

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

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/

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

proc date,time {{when ""}} {
      if {$when == ""} {set when [clock seconds]}
      clock format $when -format "%d.%m.%y,%H:%M:%S"
} ;#RS

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

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
}

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}

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
}

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

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

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)

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
}

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

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

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

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

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

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

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

 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

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

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

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

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

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
}

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

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 proc_name {} {
    lindex [info level -1] 0
} ;#RS

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

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]

# 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

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"

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

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

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

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

lassign [list $b $a] a b

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

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]

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
}