linguist/samples/Tcl/filenames/owh

#!/usr/bin/env tclsh
# http://wiki.tcl.tk/906

if {[llength $argv] < 1} {
   puts "usage: owh ?init? body ?exit?
   performs body (in Tcl) for each line (\$0) from stdin
   owh: Ousterhout - Welch - Hobbs, to name a few"
   exit -1
}

proc awksplit {text {split default}} {
    set no 0
    if {$split eq "default"} {
        set t {}
        foreach string [split $text] {
            if {$string ne {}} {
                lappend t $string
            }
        }
    } else {
        set t [list $text $split]
    }
    uplevel 1 [list set NF [llength $t]]
    foreach i $t {uplevel 1 [list set [incr no] $i]}
    uplevel 1 {set 0 {};trace variable 0 ru 0}
}
proc 0 {_name index op} {
    switch $op {
        r {
            uplevel {
                set 0 {}
                for {set i 1} {$i <= $NF} {incr i} {lappend 0 [set $i]}
                set 0 [join $0 $OFS]
            }
        }
        u {rename 0 {} ;# leave no traces of the trace..}
    }
}

proc print s {if {[catch {puts $s}]} exit} ;# good for broken pipe

set FS default
set OFS { }

if {[llength $argv] > 1} {
   eval [lindex $argv 0]
   set _body [lindex $argv 1] ;# strip outer braces
   set _exit [lindex $argv 2]
} else {
   set _body [lindex $argv 0] ;# strip outer braces
   set _exit {}
}

set NR 1
while 1 {
   gets stdin line
   if {[eof stdin]} break
   awksplit $line $FS
   eval $_body
   incr NR
}
set res [eval $_exit]
if {[string length $res]} {puts $res}