Description  edit

http://tcllib.sf.net/

Unix-like utilities  edit

here

awk

diff in Tcl

a trifle long, so it's off in its own page.

find

see fileutil, a module in tcllib

grep

See also fileutil, a module in tcllib

ls -l in Tcl

also a trifle long, and off on its own page.

od

Dump a file in hex and ASCII

sed

sort

tr

uniq

wc

anytop

indirectly Unix-inspired and perhaps a useful stub

Miscellaneous  edit

Debugging

Tk events

Balloon help

Re-encoding strings

Advanced split

simple socket communication

Sample Math Programs

try ... finally ...

find  edit

proc find {{basedir .} {filterScript {}}} {
    set oldwd [pwd]
    cd $basedir
    set cwd [pwd]
    set filenames [glob -nocomplain * .*]
    set files {}
    set filt [string length $filterScript]
    foreach filename $filenames {
        if {!$filt || [eval $filterScript [list $filename]]} {
            lappend files [file join $cwd $filename]
        }
        if {[file isdirectory $filename]} {
            set files [concat $files [find $filename $filterScript]]
        }
    }
    cd $oldwd
    return $files
}

package require tcllib 
set listOfFiles [fileutil::find $_basedir $_filterScript]

package require fileutil

Example usage:

find . {string match *.txt}

find . {file isfile}

find . {file readable}

find . {file size}

proc criterion filename {
    expr {
        [file isfile $filename]   && [file size $filename] &&
        [file readable $filename] && [string match *.txt $filename]
    }
}
find . criterion

proc isDirWithDescription filename {
    if {![file isdirectory $filename]} {return -code continue {}}
    cd $filename
    set l [llength [glob -nocomplain description.txt]]
    cd ..
    return $l
}
find . isDirWithDescription

sed  edit

proc substFile {regexp replacement inputFile outputFile} {
    set fin [open $inputFile r]
    set fout [open $outputFile w]
    while {[gets $fin linein] >= 0} {
        regsub $regexp $linein $replacement lineout
        puts $fout $lineout
    }
    close $fin
    close $fout
}

proc substGlobalFile {regexp replacement inputFile outputFile} {
    set fin [open $inputFile r]
    set fout [open $outputFile w]
    while {[gets $fin linein] >= 0} {
        regsub -all $regexp $linein $replacement lineout
        puts $fout $lineout
    }
    close $fin
    close $fout
}

proc transformFile {from to inputFile outputFile} {
    set map {}
    foreach f [split $from {}] t [split $to {}] {
        lappend map $f $t
    }
    set fin [open $inputFile r]
    set fout [open $outputFile w]
    while {[gets $fin line] >= 0} {
        puts $fout [string map $map $line]
    }
    close $fin
    close $fout
}

sort  edit

puts -nonewline [join [lsort [split [read stdin] \n]] \n]

sort

proc sort {args} {
    
    ### Parse the arguments
    set idx [lsearch -exact $args --]
    if {$idx >= 0} {
        set files [lrange $args [expr {$idx+1}] end]
        set opts  [lrange $args 0 [expr {$idx-1}]]
    } else {
        # We need to guess which are files and which are options
        set files [list]
        set opts [list]
        foreach arg $args {
            incr idx
            if {[file exists $arg]} {
                set files [lrange $args $idx end]
                break
            } else {
                lappend opts $arg
            }
        }
    }
    
    ### Read the files
    set lines [list]
    if {[llength $files] == 0} {
        # Read from stdin
        while {[gets stdin line] >= 0} {lappend lines $line}
    } else {
        foreach file $files {
            if {[string equal $file "-"]} {
                set f stdin
                set close 0
            } else {
                set f [open $file r]
                set close 1
            }
            while {[gets $f line] >= 0} {lappend lines $line}
            if {$close} {close $f}
        }
    }
    
    ### Sort the lines in-place (need 8.3.0 or later for efficiency)
    set lines [eval [list lsort] $opts \
            [lrange [list $lines [set lines {}]] 0 0]]

    ### Write the sorted lines out to stdout
    foreach line $lines {
        puts stdout $line
    }
}

uniq  edit

proc uniq args {
    ### Parse the arguments
    if {[llength $args] && [string equal [lindex $args 0] "-c"]} {
        set count 1
        set args [lrange $args 1 end]
    } else {
        set count 0
    }
    # No args is equivalent to specifying stdin
    if {![llength $args]} {set args -}

    set last {}
    set line {}
    set n 0
    foreach file $args {
        if {[string equal $file "-"]} {
            set f stdin
            set closeme 0
        } else {
            set f [open $file r]
            set closeme 1
        }
        while {[gets $f line] >= 0} {
            if {[string equal $line $last] && $n>0} {
                incr n
            } else {
                if {$count} {
                    if {$n>0} {puts [format "%4d %s" $n $last]}
                } else {
                    puts $line
                }
                set last $line
                set n 1
            }
        }
        if {$closeme} {close $f}
    }
    if {$count && $n>0} {
        puts [format "%4d %s" $n $last]
    }
}

tr  edit

# This procedure implements a [[tr]] command akin to the shell one.
proc tr { from to string } {
    set mapping [list]
    foreach c1 [trExpand $from] c2 [trExpand $to] {
       lappend mapping $c1 $c2
    }
    return [string map $mapping $string]
}

# This helper procedure takes a string of characters like A-F0-9_ and expands it to a list of characters like {A B C D E F 0 1 2 3 4 5 6 7 8 9 _}

proc trExpand { chars } {
    set state noHyphen
    set result [list]
    foreach c [split $chars {}] {
       switch -exact -- $state {
           noHyphen {
               set lastChar $c
               lappend result $c
               set state wantHyphen
           }
           wantHyphen {
               if { [string equal - $c] } {
                   set state sawHyphen
               } else {
                   set lastChar $c
                   lappend result $c
               }
           }
           sawHyphen {
               scan $lastChar %c from
               incr from
               scan $c %c to
               if { $from > $to } {
                   error "$lastChar does not precede $c."
               }
               for { set i $from } { $i <= $to } { incr i } {
                   lappend result [format %c $i]
               }
               set state noHyphen
           }
       }
    }
    if { [string equal sawHyphen $state] } {
       lappend result -
    }
    return $result
}
 
# The following call shows that rot13 works

puts [tr A-Za-z N-ZA-Mn-za-m {Guvf vf n grfg}]

# The following call shows the use of tr to eliminate certain characters 

puts [tr A-Z {} {THISthis ISis Aa TESTtest}]

proc tr { from to string } {
    return [exec tr $from $to << $string]
}

wc  edit

proc wc {filename} {
    foreach i {l w c} {
        set $i 0
    }

    set f [open $filename]

    while true {
        set txt [gets $f]
        if [eof $f] break

        incr l
        incr w [regexp -all {[^[:space:]]+} $txt]
        incr c [expr {[string length $txt] + 1}]
    }

    close $f
    return [list $l $w $c]
}

Debugging  edit

proc Exec {args} {
  puts stderr $args
  eval exec $args
}

proc tracedEval {script {execLevel 3} {compileLevel 2}} {
    global tcl_traceCompile tcl_traceExec errorCode errorInfo

    # Set the debugging levels
    set tcl_traceCompile $compileLevel
    set tcl_traceExec $execLevel

    # Execute the script, handling any failures
    set code [catch {uplevel $script} msg]

    # Restore the debugging levels to normal running.
    # I assume that you normally have these vars set to 0
    set tcl_traceExec 0
    set tcl_traceCompile 0

    # Pass on all errors thrown in the script to our caller
    return -code $code -errorcode $errorCode -errorinfo $errorInfo $msg
}

Tk Events  edit

bind . <KeyPress> {
    set dec ""; scan %A %%c dec
    puts "keysym:%K prints:%A ($dec)"
} ;#-------------- and to turn this off again:
bind . <KeyPress> {}

proc unk {e} {bind . <$e> "puts $e"}

tcl> source program.tcl

tcl> 

tcl program.tcl

tkcon

JStrack

Re-encoding strings  edit

set fixed_string [encoding convertfrom $right_encoding [encoding convertto $wrongencoding $string]]

Re-encoding files  edit

#! /usr/bin/tclsh
# (or whatever incantation works for you)

proc main {fromTransl fromEnc toTransl toEnc} {
    fconfigure stdin -translation $fromTransl -encoding $fromEnc
    fconfigure stdout -translation $toTransl -encoding $toEnc
    fcopy stdin stdout
}
main {*}$argv ; # Leverage error thrown by procs for reminder of correct syntax

cat macClassicFile.txt | ''scriptname'' cr macRoman lf utf-8 >macOSXFile.txt
cat macOSXFile.txt | ''scriptname'' lf utf-8 cr macRoman >macClassicFile.txt

Advanced split  edit

proc xsplit [list str [list regexp "\[\t \r\n\]+"]] {
    set list  {}
    while {[regexp -indices -- $regexp $str match submatch]} {
       lappend list [string range $str 0 [expr [lindex $match 0] -1]]
       if {[lindex $submatch 0]>=0} {
           lappend list [string range $str [lindex $submatch 0]\
                   [lindex $submatch 1]] 
       }       
       set str [string range $str [expr [lindex $match 1]+1] end] 
    }
    lappend list $str
    return $list
}

Simple socket communication  edit

#!/bin/sh
# \
exec tclsh "$0" "$@"
proc serveConnection {Handle} {
    set LineLength [gets $Handle Line]
    if {$LineLength>=0} {
        #This is where you finally can do something with the data.
        #We simply put it back where it came from.
        puts $Handle "Received: $Line"; flush $Handle 
    } elseif {[eof $Handle]} {
        catch {close $Handle}
    }
}
proc acceptConnections {ConnectionFileHandle ClientAddress ClientPort} {
    fconfigure $ConnectionFileHandle -blocking 0
    fileevent $ConnectionFileHandle readable [list \
            catch [list serveConnection $ConnectionFileHandle]]
}
socket -server acceptConnections 2000
vwait Dummyvariable

#!/bin/sh
# \
exec tclsh "$0" "$@"

set Handle [socket localhost 2000]
puts -nonewline $Handle "Hello"; flush $Handle 
puts $Handle " Dolly"; flush $Handle 
puts [gets $Handle]
close $Handle 

#!/usr/bin/env tclsh

proc done {} { set ::done 1 }

proc process {fd ip port} {
    if {!([eof $fd] || [catch {gets $fd line }]) } {
        if {[string length $line] == 0} { return }
        if {[string match exit $line]} { close $fd ; return }
        if {[string match done $line]} { close $fd ; done ; return }
        puts $fd "input : $line"
    } else {
        catch { close $fd }
    }
}

proc accept {fd ip port} {
    fconfigure $fd -blocking 0 -buffering line
    fileevent $fd readable [list process $fd $ip $port]
}
proc listen {port} {
    socket -myaddr 127.0.0.1 -server accept $port
    vwait done
}

listen 2000

• A Server Template

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