一些有用的proc(转自http://wiki.tcl.tk)

Grep does an awful lot of different things, and implementing a full version of it is probably a worthy topic for a Wiki page to itself. Here's something to get you started... - DKF

   proc grep {pattern args} {
       if {[llength $args] == 0} {
           # read from stdin
           set lnum 0
           while {[gets stdin line] >= 0} {
               incr lnum
               if {[regexp $pattern $line]} {
                   puts "${lnum}:${line}"
               }
           }
       } else {
           foreach filename $args {
               set file [open $filename r]
               set lnum 0
               while {[gets $file line] >= 0} {
                   incr lnum
                   if {[regexp $pattern $line]} {
                       puts "${filename}:${lnum}:${line}"
                   }
               }
               close $file
           }
       }
   }

 package require tcllib
 set listOfMatches [fileutil::grep $_pattern]            ;# (stdin input)
 set listOfMatches [fileutil::grep $_pattern $_fileList]

 proc grep {pattern args} {
    if {[llength $args] == 0} {
       grep0 "" $pattern stdin
    } else {
       foreach filename $args {
           set file [open $filename r]
           grep0 ${filename}: $pattern $file
           close $file
       }
    }
 }
 proc grep0 {prefix pattern handle} {
      set lnum 0
      while {[gets $handle line] >= 0} {
          incr lnum
          if {[regexp $pattern $line]} {
              puts "$prefix${lnum}:${line}"
          }
      }
 }

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

    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
Doing a full sed replacement is hard. It is better to just write a Tcl program/procedure from scratch that implements the functionality. This is probably easier though if someone implements some kind of line iterator (suitable for most simple uses of sed where all you want to do is apply a substitution to each line of a file/stream or only print some lines.) It is probably easier to just run sed externally (with [exec]) for anything that is very complex and where you've not the time to reimplement. 
However, as a little goodie, here are some alternatives to very common sed commands... 
sed "s/RE/replacement/" <inputFile >outputFile  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
Yet again, we have a little program that really does an awful lot. If we don't care about options and argument processing, it can be done as a one-liner:  puts -nonewline [join [lsort [split [read stdin] \n]] \n]

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

 sort -integer -decreasing -- numberfile1.txt numberfile2.txt

uniq
This is actually one of the simplest Unix utilities, but even so I will only produce a cut-down version here. The only option I support is -c (to precede each line by the number of times in sequence it occurs.) 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
The following implementation of tr shows how [string map] can be used to transliterate characters. A production implementation would probably maintain a cache of the translation list going into [string map], but this implementation gives the basics. Note that the implementation didn't need to do anything special to be Unicode-aware; you can, for instance, use it to substitute Katakana for Hiragana by doing [tr \u3041-\u309e \u30a1-\u30fe $japaneseString] 
# 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]
 }

 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
 }

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

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

• TclX implements it; and
• if tr is available externally, it's quick to write

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

wc
The following implements the default behavior of wc, i.e. when called without any flags. 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]
 }

For Debugging     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
— especially keypress events 
This little script will echo all keyboard events to stdout:    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"}

Balloon help
— sometimes called "tooltips"    #!/usr/local/bin/wish

    proc balloon_help {w msg} {
        bind $w <Enter> "after 1000 \"balloon_aux %W [list $msg]\""
        bind $w <Leave> "after cancel \"balloon_aux %W [list $msg]\"
                         after 100 {catch {destroy .balloon_help}}"
    }

    proc balloon_aux {w msg} {
        set t .balloon_help
        catch {destroy $t}
        toplevel $t
        wm overrideredirect $t 1
        if {$::tcl_platform(platform) == "macintosh"} {
         unsupported1 style $t floating sideTitlebar
        }
        pack [label $t.l -text $msg -relief groove -bd 1 -bg gold] -fill both
        set x [expr [winfo rootx $w]+6+[winfo width $w]/2]
        set y [expr [winfo rooty $w]+6+[winfo height $w]/2]
        wm geometry $t +$x\+$y
        bind $t <Enter> {after cancel {catch {destroy .balloon_help}}}
        bind $t <Leave> "catch {destroy .balloon_help}"
    }

    # demo
    pack [button .b -text tryme -command {puts "you did it!"}]
    balloon_help .b "Text that describes\nwhat the button does"

 bind $w <Enter> [list after 1000 [list balloon_aux %W [string map {"%" "%%"} $msg]]] ;#GPS

If you have an event driven program, end it with tclx mainloop. 
Then you can tcl> source program.tcl

 tcl>

 tcl program.tcl

Re-encoding strings

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

Re-encoding files
Here's a unix-style filter that reencodes text.#! /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
If you need to split string into list using some more complicated rule than builtin split command allows, use following function  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
The beauty of scripting lies (a.o.) in the fact that you can have lots of little programs cooperating with each other. For this, a simple means of communication is necessary. This simple server (and even simpler client) show how it works: 
Server: #!/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