proc gregsub {re txt block} {
set res {}
while 1 {
set part [lindex [regexp -inline $re $txt] 1]
if {![string length $part]} {
append res $txt
break
}
set lst [split [regsub -- $re $txt "\0"] "\0"]
append res [lindex $lst 0] [apply $block $part]
set txt [lindex $lst 1]
}
return $res
}
proc regrange {p1 sep p2 data block} {
set on 0
set delay 0
if {![string compare $sep "..."]} {
set delay 1
}
if ![llength $p1] { ; set on 1
set p1 {$-^} ; }
foreach line $data {
switch -exact -- $sep {
{..} {
if {[regexp -- $p1 $line]} {set on 1} elseif {[regexp -- $p2 $line]} {set delay 1}
if {$on} {
apply $block $line
}
if {$delay} {
set on 0
set delay 0
}
}
{...} {
if {[regexp -- $p1 $line]} {set delay 0} elseif {[regexp -- $p2 $line]} {set on 0}
if {$on} {
apply $block $line
}
if {!$delay} {
set on 1
set delay 1
}
}
default {
error "wrong range operator $sep"
}
}
}
}
proc with-file {file block} {
set fd [open $file]
uplevel 1 [list apply $block $fd]
close $fd
}
proc read-lines {fd block} {
while {[gets $fd line] >= 0} {
uplevel 1 [list apply $block $line]
}
}
proc readlines {fd block} {
set data [read -nonewline $fd]
set variable options
set cr "\n"
if [info exist options(CR)] {
set cr $options(CR)
}
foreach line [split [regsub -all -- $cr $data "\0" ] "\0" ] {
uplevel 1 [list apply $block $line]
puts -nonewline $cr
}
}
proc argf-iter {block} {
variable options
foreach file $::argv {
with-file $file [list fd "return \[readlines \$fd {$block}\]"]
}
}
set string {\n} ;
set string "jon 'maddog' orwant" ;
set string \n ;
set string "jon \"crosby\" orwant" ;
set string {jon "stills" orwant} ;
set string "jon {nash} orwant" ;
set string {jon {young} orwant} ;
set a {
this is a multiline string
terminated by an unescaped and
{unnested} right brace (\})
}
set value [string range $string $first $last]
set value [string range $string $first [expr {$first+$count-1}]]
set value [string range $string $first end]
set string [string replace $string $first $last $newstring]
set string [string replace $string $first [expr {$first+$count-1}] $newstring]
set string [string replace $string $first end $newtail]
binary scan $data "A5 x3 A8 A8 A*" leading s1 s2 trailing
encoding convertto utf-8 "H\u2082O is the chemical formula for water"
set fivers [list]
set temp [encoding convertto utf-8 $string]
while {[binary scan $temp a5a* group tail]} {
lappend fivers $group
set temp $tail
}
if {[string length $tail]} { lappend fivers $tail }
set fivers
set fivers [regexp -all -inline {.{1,5}} $data]
set chars [split $data {}]
set first [string index "This is what you have" 0]
set start [string range "This is what you have" 5 6]
set rest [string range "This is what you have" 13 end]
set last [string index "This is what you have" end]
set end [string range "This is what you have" end-3 end]
set piece [string range "This is what you have" end-7 end-5]
set string [string replace "This is what you have" 5 6 wasn't]
set string [string replace "This wasn't what you have" end-11 end ondrous]
set string [string range "This wasn't wondrous" 1 end]
set string [string range "his wasn't wondrous" 0 end-10]
if {[regexp $pattern [string range $string end-9 end]]} {
return "Pattern matches in last 10 characters"
} else {
return "Match failed"
}
regsub -all is [string range $string 0 4] at newstring
set string [string replace $string 0 4 $newstring]
regsub {(.)(.*)(.)} "make a hat" {\3\2\1} a
puts $a
set b [string range "To be or not to be" 6 11]
set a "To be or not to be"
set b [string range $a 6 7]
append b : [string range $a 3 4]
proc cut2fmt {args} {
set positions $args
set template {}
set lastpos 1
foreach {place} $positions {
append template "A[expr {$place-$lastpos}] "
set lastpos $place
}
append template A*
return $template
}
set fmt [cut2fmt 8 14 20 26 30]
if {[string length $b]} {
set a $b
} else {
set a $c
}
if {$b != 0} {
set a $b
} else {
set a $c
}
if {![string length $x]} {
set x $y
}
if {$x == 0} {
set x $y
}
if {[info exists b]} {
set a $b
} else {
set a $c
}
set arg [lindex $argv 0]
set argv [lrange $argv 1 end]
if {[string length $arg]} {
set dir $arg
} else {
set dir /tmp
}
set arg [lindex $argv 0]
if {[string length $arg]} {
set dir $arg
} else {
set dir /tmp
}
if {[info exists argv] && [llength $argv]} {
set dir [lindex $argv 0]
set argv [lrange $argv 1 end]
} else {
set dir /tmp
}
if {[llength $argv]} {
set dir [lindex $argv 0]
} else {
set dir /tmp
}
if {![string length $shell]} {
set shell /bin/sh
}
if {[info exist count($shell)]} {
incr count($shell)
} else {
set count($shell) 1
}
if {![catch {string length $env(USER)}]} {
set user $env(USER)
} elseif {![catch {string length $env(LOGIN)}]} {
set user $env(LOGIN)
} else {
set user "Unknown user"
}
set ::tcl_platform(user)
if {![string length $startingPoint]} {
set startingPoint Greenwich
}
if {[llength $x] == 0} {
set x $y
}
if {[llength $y]} {
set x $y
} else {
set x $z
}
foreach {b a} $args break
set temp $a
set a $b
set b $temp
unset temp
foreach {alpha beta production} [list January March August] break
foreach {alpha beta production} [list $beta $production $alpha] break
set num [scan $char %c]
set char [format %c $num]
format "Number %d is character %c" 101 101
set utf8data [encoding convertto utf-8 $string]
binary scan $utf8data c* codelist
set utf8data [binary format c* $codelist]
set string [encoding convertfrom utf-8 $utf8data]
proc hal2ibm {} {
set hal HAL
binary scan $hal c* codes
foreach {num} $codes {
lappend newcodes [incr num]
}
set ibm [binary format c* $newcodes]
}
hal2ibm
set a [split $string {}]
set utf8data [encoding convertto utf-8 $string]
binary scan $utf8data c* a
foreach 1 [regexp -inline -all -line . $string] {
}
proc indChars-1 {s} {
array set seen [list]
set string $s
foreach {char} [split $string {}] {
if {[info exists seen($char)]} {
incr seen($char)
} else {
set seen($char) 1
}
}
puts "unique chars are: {[join [lsort [array names seen]] {}]}"
}
indChars-1 "an apple a day"
proc uniqueChars-1 {s} {
puts "unique chars are: {[join [lsort -unique [split $s {}]] {}]}"
}
uniqueChars-1 "an apple a day"
proc simpleChecksum {string} {
set sum 0
binary scan $string c* codes
foreach {code} $codes {
incr sum $code
}
return $sum
}
simpleChecksum "an apple a day"
package require Trf
binary scan [crc {an apple a day}] H* checksum
set checksum
proc slowcat {args} {
set delay 1
if {[llength $args]} {
if {[regexp {^-([.\d]+)} [lindex $args 0] match delay]} {
set args [lrange $args 1 end]
}
}
fconfigure stdout -buffering no
if {[llength $args]} {
foreach {arg} $args {
set f [open $arg]
lappend channels $f
}
} else {
set channels stdin
}
foreach {chan} $channels {
while {[gets $chan line] > -1} {
foreach {ch} [split $line {}] {
puts -nonewline $ch
after [expr {int(5 * $delay)}]
}
puts {}
}
}
}
proc reverse {args} {
set res [list]
if {[llength $args] == 1} {
set args [lindex $args 0]
}
foreach elem $args {
set res [linsert $res 0 $elem]
}
return $res
}
join [reverse [split $string {}]] {}
join [reverse [split $string]]
join [reverse [split {Yoda said, "can you see this?"}]]
set word reviver
set is_palindrome [string equal $word [join [reverse [split $word]]]]
package require textutil
namespace import ::textutil::tabify::*
tabify "... zzz xxx"
untabify "...\tzzz\txxx"
tabify2 "... zzz xxx"
untabify2 "...\tzzz\txxx"
set debt 100
subst "You owe $debt to me."
set debt 100
proc writeIt {string} {
uplevel subst [list $string]
}
writeIt {You owe $debt to me.}
foreach {rows cols} {24 80} break
set text {I am $rows high and $cols long}
subst $text
set string "I am 17 years old"
regsub -all {(\d+)} $string {[expr {\1*2}]} string
subst $string
proc expandOrError-1 {@text} {
upvar ${@text} text
while {[regexp {\$(\w+)} $text match var]} {
if {[uplevel info exists $var]} {
regsub \\$match $text [uplevel set $var] text
} else {
regsub \\$match $text "\[NO VARIABLE: $var\]" text
}
}
set text
}
proc safeExpand-1 {string} {
set si [interp create -safe]
set res [uplevel $si eval [list subst [list $string]]]
interp delete $si
set res
}
safeExpand-1 {[exec rm foo.bar]}
set little "bo peep"
set big [string toupper $little]
set big "BO PEEP"
set little [string tolower $big]
set little "bo peep"
set title [string totitle $little]
set little "bo peep"
set big [string toupper $little 0]
set big "BO PEEP"
set little [string tolower $big 0]
set name {kirk}
set string "Ship's Captain: [string totitle $name]."
set text "thIS is a loNG liNE"
set pos 0
while {[regexp -indices -start $pos {(\w+)} $text where]} {
foreach {first last} $where break
set text [string totitle $text $first $last]
set pos $last
incr pos
}
puts $text
foreach word "thIS is a loNG liNE" {
lappend words [string totitle $word]
}
puts $words
string equal -nocase foo Foo
set text {
001:001 In the beginning God created the heaven and the earth.
001:002 And the earth was without form, and void; and darkness was
upon the face of the deep. And the spirit of God moved upon
the face of the waters.
001:003 And God said, let there be light: and there was light.
}
set pos 0
while {[regexp -indices -start $pos {(\w)} $text where]} {
foreach {first last} $where break
if {rand()<=0.2} {
set text [string toupper $text $first]
} else {
set text [string tolower $text $first]
}
set pos $last
incr pos
}
puts $text
set var1 Tool
proc func {s} {string totitle $s}
set var2 Language
set answer "$var1 [func command] $var2"
set n 5
set phrase "I have [expr {$n + 1}] guanacos."
set rec foo:bar:baz
interp alias {} some_cmd {} join
some_cmd "What you want is [llength [split $rec :]] items"
set text {
To: $naughty
From: Your Bank
Cc: [getManagerList $naughty]
Date: [clock format [clock seconds]] (today)
Dear $naughty,
Today, you bounced check number [expr {500 + int(rand()*100)}] to us.
Your account is now closed.
Sincerely,
the management
}
if {![sendMail $text $target]} {
error "Couldn't send mail"
}
regsub -line -all {^\s+} {
your text
goes here
} {} var
format %s \n$var
set var {
your text
goes here
}
regsub -line -all {^\s+} $var {} var
format %s \n$var
regsub -line -all {^\s+} {
The five varieties of camelids
are the familiar camel, his friends
the llama and the alpaca, and the
rather less well-known guanaco
and vicuña.
} {} definition
proc fix {string} {
regsub -line -all {^\s+} $string {} string
return $string
}
fix {
My stuff goes here
}
regsub -line -all {^\s+} {
...we will have peace, when you and all your works have
perished--and the works of your dark master to whom you would
deliver us. You are a liar, Saruman, and a corrupter of men's
hearts. --Theoden in /usr/src/perl/taint.c
} {} quote ;regsub {\s+--} $quote \n-- quote
format %s \n$quote
proc rememberTheMain {} {
dequote {
@@@ int
@@@ runops() {
@@@ SAVEI32(runlevel);
@@@ runlevel++;
@@@ while ( op = (*op->op_ppaddr)() ) ;
@@@ TAINT_NOT;
@@@ return 0;
@@@ }
}
}
proc roadGoesEverOn {} {
dequote {
Now far ahead the Road has gone,
And I must follow, if I can,
Pursuing it with eager feet,
Until it joins some larger way
Where many paths and errands meet.
And whither then? I cannot say.
--Bilbo in /usr/src/perl/pp_ctl.c
}
}
proc quotemeta {string} {
regsub -all {(\W)} $string {\\\1} string
return $string
}
proc dequote {text} {
if {[regexp -line {^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+(?:\s*)$} $text m 1 2]} {
set white $2
set leader [quotemeta $1]
} else {
regexp -line {^\n?(\s+)} $text m white
set leader {}
}
regsub -line -all ^\\s*?$leader\(?:$white\) $text {} text
return [string trimright $text]\n
}
proc wrap {text {col 72} {lead {}} {follow {}}} {
set newtext {}
set text $lead[string trimleft $text]
set upto $col
while {![string is wordchar [string index $text $upto]]} {incr upto -1}
set upto [string wordstart $text $upto]
if {$upto == 0} {
set upto [string wordend $text $upto]
} else {
incr upto -1
}
append newtext [string range $text 0 $upto]\n
set text [string replace $text 0 $upto]
while {[string length $text]} {
set text $follow[string trimleft $text]
if {[string length $text] > $col} {
set upto $col
while {![string is wordchar [string index $text $upto]]} {incr upto -1}
set upto [string wordstart $text $upto]
if {$upto == 0} {
set upto [string wordend $text $upto]
} else {
incr upto -1
}
append newtext [string range $text 0 $upto]\n
set text [string replace $text 0 $upto]
} else {
append newtext $text
set text {}
}
}
return $newtext
}
set input {"Folding and splicing is the work of an editor,"
"not a mere collection of silicon"
"and"
"mobile electrons!"}
append res \n [string repeat 0123456789 2] \n
append res [wrap [join $input] 20 { } { }] \n
regsub -all (\[$charlist]) $var {\\\1} var
regsub -all (\[$charlist]) $var {\1\1} var
set string {Mom said, "Don't do that."}
regsub -all {(['"])} $string {\\\1} string
puts $string
# => Mom said, \"Don\'t do that.\"
set string {Mom said, "Don't do that."}
regsub -all {(['"])} $string {\1\1} string
puts $string
set string {Mom said, "Don't do that."}
regsub -all {([^A-Z])} $string {\\\1} string ;puts $string
regsub -all {([^[:alnum:]])} "is a test!" {\\\1} string
puts "this $string"
string trim "\n\t Tcl \t\n"
set string {
foo bar
baz
}
set res [list]
foreach {s} [split $string \n] {
lappend res [string trim $s]
}
string trim [join $res]
string trimright "foo bar\n\n" \n
package require csv
set line {XYZZY,,"O'Reilly, Inc","Wall, Larry","a ""glug"" bit",5,"Error, Core Dumped"}
set fields [::csv::split $line]
set res {}
for {set i 0} {$i < [llength $fields]} {incr i} {
append res \n "$i : [lindex $fields $i]"
}
puts $res
array set ::data {
analysed analyzed
built-in builtin
chastized chastised
commandline command-line
de-allocate deallocate
dropin drop-in
hardcode hard-code
meta-data metadata
multicharacter multi-character
multiway multi-way
non-empty nonempty
non-profit nonprofit
non-trappable nontrappable
pre-define predefine
preextend pre-extend
re-compiling recompiling
reenter re-enter
turnkey turn-key
}
set testtext {
Yesterday we analysed the efficiency of the
built-in thingummies and were considerably
chastized by the results. It seems that
commandline invocation forced the
whatchamacallit to de-allocate dropin
maguffins. First, we tested instead to
hardcode meta-data -- especially when in
multicharacter and multiway format
(obviously only for non-empty data sets).
However, that turned out to be a non-profit
improvement. Dr Egnarts then demonstrated
using non-trappable signals in pre-define
mode to preextend save rates. When
re-compiling we saw the application reenter
acceptable ratings on turnkey operations.
}
if {[llength $argv] && [string equal [lindex $argv 0] -v]} {
set ::verbose yes
set argv [lrange $argv 1 end]
} else {
set ::verbose no
}
set text {}
if {[string match *test [info script]]} {
set text $testtext
} else {
if {[info exists argv]} {
foreach {fn} [lrange $argv 0 end] {
if {![catch {open $fn} chan]} {
append text [read $chan]
close $chan
}
}
}
if {![string length $text]} {
if {[tell stdin] == -1} {
puts stderr "[info script]: Reading from stdin"
}
set text [read stdin]
}
}
proc fixstyle {text} {
global data verbose
set newtext [list]
foreach w $text {
if {[catch {set word $data($w)}]} {
set word $w
} else {
if {$verbose} {
puts stderr "$w => $word"
}
}
lappend newtext $word
}
return $newtext
}
fixstyle $text
proc warn {msg cond pattern {string 0}} {
if {[string equal if $cond]} {
if {[regexp $pattern $string]} {
return [format "%s: %s" $string $msg]
}
} elseif {[string equal unless $cond]} {
if {![regexp $pattern $string]} {
return [format "%s: %s" $string $msg]
}
}
return
}
warn "has nondigits" if {\D}
warn "not a natural number" unless {^\d+$} ;
warn "not an integer" unless {^[+-]?\d+$} ;
warn "not a real number" unless {^-?\d+\.?\d*$} ;
warn "not a C float" unless {^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$}
if {[string is integer $x]} {
set res "$x is an integer"
} elseif {[string is double $x]} {
set res "$x is a real number"
} else {
set res "$x is not a number"
}
set res
proc floatEqual-1 {num1 num2 accuracy} {
expr {[format %.${accuracy}f $num1] == [format %.${accuracy}f $num2]}
}
set wage 536 ;set week [expr {40 * $wage}] ;format "One week's wage is: \$%.2f" [expr {$week/100.0}]
set a 0.255
set b [format %.2f $a]
puts "Unrounded: $a"
puts "Rounded: $b"
set res \nnumber\tint\tfloor\tceil\n
set a [list 3.3 3.5 3.7 -3.3]
foreach n $a {
append res [format %.1f\t $n]
append res [format %.1f\t [expr {int($n)}]]
append res [format %.1f\t [expr {floor($n)}]]
append res [format %.1f\n [expr {ceil($n)}]]
}
puts $res
proc dec2bin {string} {
binary scan [binary format I $string] B32 str
return [string trimleft $str 0]
}
dec2bin 54
proc bin2dec {string} {
set string [format %032s $string]
binary scan [binary format B32 $string] I str
return $str
}
bin2dec 110110
for {set i $X} {$i <= $Y} {incr i} {
}
for {set i $X} {$i <= $Y} {incr i 7} {
}
set res {}
append res "Infancy is: "
foreach i [list 0 1 2] {
append res "$i "
}
proc .. {low high} {
for {set i $low} {$i <= $high} {incr i} {
lappend res $i
}
set res
}
append res \n
append res "Toddling is: "
foreach i [.. 3 4] {
append res "$i "
}
append res \n
append res "Childhood is: "
for {set i 5} {$i <= 12} {incr i} {
append res "$i "
}
puts $res
roman:number 15
roman:get XV
puts [expr {int(rand()*51)+25}]
package require math
puts [::math::random 25 76]
set list [split {Demonstrate selecting a random element from a list.}]
package require math
puts [lindex $list [::math::random [llength $list]]]
package require math
set password {}
for {set i 0} {$i < 8} {incr i} {
append password [lindex $chars [::math::random [llength $chars]]]
}
puts $password
set value 1138
expr {srand($value)}
variable PI [expr {acos(-1)}]
puts [set [namespace current]::PI]
proc deg2rad {degrees} {
variable PI
return [expr {$degrees / 180.0 * $PI}]
}
proc rad2deg {radians} {
variable PI
return [expr {$radians / $PI * 180}]
}
proc degreeSine {degrees} {
set radians [deg2rad $degrees]
return [expr {sin($radians)}]
}
list [catch {expr {1/0}} msg] $msg
set value 1138
puts [expr {log($value)}]
set value 1138
puts [expr {log10($value)}]
proc logN {base value} {
return [expr {log($value) / log($base)}]
}
package require struct 1.1.1
proc mmult {m1 m2} {
set m1rows [$m1 rows]
set m1cols [$m1 columns]
set m2rows [$m2 rows]
set m2cols [$m2 columns]
if {$m1cols != $m2rows} {
error "IndexError: matrices don't match: $m1cols != $m2rows"
}
::struct::matrix result
result add rows $m1rows
result add columns $m2cols
for {set i 0} {$i < $m1rows} {incr i} {
for {set j 0} {$j < $m2cols} {incr j} {
set v 0
for {set k 0} {$k < $m1cols} {incr k} {
incr v [expr {[$m1 get cell $k $i] * [$m2 get cell $j $k]}]
}
result set cell $j $i $v
}
}
return result
}
::struct::matrix x
x add columns 3
x add row [list 3 2 3]
x add row [list 5 9 8]
::struct::matrix y
y add rows 3
y add column [list 4 9 3]
y add column [list 7 3 1]
set res [mmult x y]
$res get rect 0 0 end end
complex::* 3+5i 2-2i
proc hex {string} {
if {[regexp -nocase {^0x} $string]} {
return [expr $string]
} else {
return [expr 0x$string]
}
}
proc oct {string} {
if {[regexp -nocase {^0x} $string]} {
return [hex $string]
} else {
return [expr 0$string]
}
}
if {[string match *.test [info script]]} {
set num 0x39a
} else {
puts "Gimme a number in decimal, octal, or hex: "
set num [gets stdin]
}
if {[string length $num]} {
if {[regexp ^0 $num]} {
set num [oct $num]
}
format "%d %x %o" $num $num $num
}
proc comma {num {sep ,}} {
while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1$sep\\2" num]} {}
return $num
}
set data [join {fish fly ox
species genus phylum
cherub radius jockey
index matrix mythos
phenomenon formula}]
set res {}
foreach word $data {
append res "One $word, two [en:pl $word]\n"
}
puts $res
primefactors 2178
primefactors 2099999990
set now [clock seconds]
puts [clock format $now]
set fmt "Today is day %j of the current year."
puts [clock format $now -format $fmt]
set now [clock seconds]
foreach {day month year} [clock format $now -format "%d %m %Y"] break
set now [clock seconds]
set fmt "%Y-%m-%d"
puts "The current date is [clock format $now -format $fmt]."
set time [clock scan "$hours:$min:$sec $year-$mon-$mday"]
set time [clock scan "$hours:$min:$sec $year-$mon-$mday" -gmt yes]
if {[string match *.test [info script]]} {
set now 1000000000
} else {
set now [clock seconds]
}
set vars [list seconds minutes hours dayOfMonth month year wday yday]
set desc [list S M H d m Y w j]
foreach v $vars d $desc {
set $v [clock format $now -format %$d]
}
format %s-%s-%sT%s:%s:%s $year $month $dayOfMonth $hours $minutes $seconds
if {[string match *.test [info script]]} {
set now 1000000000
} else {
set now [clock seconds]
}
set vars [list seconds minutes hours dayOfMonth month year wday yday]
set desc [list S M H d m Y w j]
foreach v $vars d $desc {
set $v [clock format $now -format %$d -gmt yes]
}
format %s-%s-%sT%s:%s:%s $year $month $dayOfMonth $hours $minutes $seconds
set newTime [clock scan "$y-$m-$d $offset days"]
foreach {y2 m2 d2} [clock format $newTime -format "%Y %m %d"] break
return [list $y2 $m2 $d2]
set oldTime [clock scan $time]
set newTime [clock scan "
$daysOffset days
$hourOffset hours
$minuteOffset minutes
$secondOffset seconds
" -base $oldTime]
set bree [clock scan "16 Jun 1981 4:35:25"]
set nat [clock scan "18 Jan 1973 3:45:50"]
set difference [expr {$bree - $nat}]
format "There were $difference seconds between Nat and Bree"
set bree [clock scan "16 Jun 1981 4:35:25"]
set nat [clock scan "18 Jan 1973 3:45:50"]
set difference [expr {$bree - $nat}]
set vars {seconds minutes hours days}
set factors {60 60 24 7}
foreach v $vars f $factors {
set $v [expr {$difference % $f}]
set difference [expr {($difference-[set $v]) / $f}]
}
set weeks $difference
format "($weeks weeks, $days days, $hours:$minutes:$seconds)"
set then [clock scan 6/16/1981]
set format {
%Y-%m-%d was a %A
in week number %W,
and day %j of the year.
}
clock format $then -format $format
puts [clock format [clock scan 01/18/73] -gmt yes]
puts [clock format [clock scan 01/18/73] -format "%A %D"]
set format "%a %b %e %H:%M:%S %Z %Y"
puts [clock format [clock scan "18 Jan 1973 3:45:50 GMT"] -format $format -gmt yes]
puts "Press return when ready"
set before [clock clicks -milliseconds]
gets stdin
set elapsed [expr {([clock clicks -milliseconds] - $before) / 1000.0}]
puts "You took $elapsed seconds"
set size 500
set numberOfTimes 100
set a [list]
for {set j 0} {$j < $size} {incr j} {
lappend a [expr {rand()}]
}
puts "Sorting $size random numbers:"
puts [time {
set a [lsort -real $a]
} $numberOfTimes]
after 25
set presidents [list Reagan Bush Clinton]
set nested [list this that [list the other]]
llength $nested
set tune [list The Star-spangled Banner]
list
set a [list quick brown fox]
set a "Why are you teasing me?"
set lines [list]
foreach {l} [split {
The boy stood on the burning deck,
It was as hot as glass.
} \n ] {
set line [string trimleft $l]
if {[string length $line]} {
lappend lines $line
}
}
puts $lines
set f [open $mydatafile] ;set biglist [split [read $f] \n]
lappend banner1 Costs only \$4.95
set banner2 [list Costs only \$4.95]
set banner3 [split {Costs only $4.95}]
expr {"$banner1" == "$banner2" && "$banner2" == "$banner3"}
set ships [list Niña Pinta Santa María] ;llength $ships
set ships [list Niña Pinta {Santa María}] ;llength $ships
set list [list red yellow green]
puts [list I have $list marbles.]
set list [list red yellow green]
puts "I have $list marbles."
set lists {
{{just one thing}}
{Mutt Jeff}
{Peter Paul Mary}
{{to our parents} {Mother Theresa} God}
{{pastrami} {ham and cheese} {peanut butter and jelly} {tuna}}
{{recycle tired, old phrases} {ponder big, happy thoughts}}
{{recycle tired, old phrases} {ponder big, happy thoughts} {sleep and dream peacefully} }
}
proc commifySeries {args} {
if {[regexp , $args]} {
set sepchar ";"
} else {
set sepchar ,
}
switch [llength $args] {
0 { return {} }
1 { eval return $args }
2 { return [join $args { and }] }
default {
set args [lreplace $args end end [concat and [lindex $args end]]]
return [join $args "$sepchar "]
}
}
}
proc whatAboutThatList args {
variable people
append res "The list now has [set len [llength $people]] elements.\n"
append res "The index of the last element is [incr len -1].\n"
append res "Element #3 is `[lindex $people 3]'."
}
set people [list Crosby Stills Nash Young]
whatAboutThatList
set people [lrange $people 0 end-1]
whatAboutThatList
for {set i [llength $people]} {$i <= 10000} {incr i} {
lappend people {}
}
whatAboutThatList
foreach user $badUsers {
complain $user
}
foreach key [lsort [array names env]] {
puts $key=$env($key)
}
foreach {user} $allUsers {
set diskSpace [getUsage $user]
if {$diskSpace > $MAXQUOTA} {
complain $user
}
}
foreach _ [exec who] {
if [regexp tchrist $_] {
puts $_
}
}
proc timesSeven {listname} {
upvar $listname listref
for {set i 0} {$i < [llength $listref]} {incr i} {
set listref [lreplace $listref $i $i [expr {[lindex $listref $i] * 7}]]
}
}
variable res {}
set fruits [list Apple Blackberry]
set fruitRef fruits
foreach fruit [set $fruitRef] {
append res "$fruit tastes good in a pie.\n"
}
puts $res
lsort -unique [list how much wood would a wood chuck chuck]
foreach e $list {
array set unique [list $e {}]
}
array names unique
package require Tclx
set listA [list 1 1 2 2 3 3 3 4 5]
set listB [list 1 2 4]
set res [intersect3 $listA $listB]
lindex $res 0
package require Tclx
set listA [list 1 1 2 2 3 3 3 4 5]
set listB [list 1 2 4 4 6 7]
foreach {difference intersection -} [intersect3 $listA $listB] break
set union [union $listA $listB]
list $difference $intersection $union
set members [list Time Flies]
lappend members An Arrow
set members [list Time Flies]
set initiates [list An Arrow]
set members [concat $members $initiates]
set members [list Time Flies An Arrow]
set members [linsert $members 2 Like]
set members [list Time Flies Like An Arrow]
set members [lreplace $members 0 0 Fruit]
set members [lreplace $members end-1 end A Banana]
set list [list 0 1 2 3 4 5 6 7 8 9]
set rlist [list]
for {set i [expr {[llength $list]-1}]} {$i >= 0} {incr i -1} {
lappend rlist [lindex $list $i]
}
puts $rlist
set list [list 0 1 2 3 4 5 6 7 8 9]
lsort -decreasing $list
proc splice-ish {listname number} {
upvar $listname list
set length [llength $list]
if {$number < 0} {
set number [expr {abs($number)}]
set res [lrange $list end-[expr {$number-1}] end]
set list [lrange $list 0 end-$number]
} else {
set res [lrange $list 0 [expr {$number-1}]]
set list [lrange $list $number end]
}
return $res
}
proc shift2 {listname} {
upvar $listname list
return [splice-ish list 2]
}
set friends [list Peter Paul Mary Jim Tim]
foreach {this that} [shift2 friends] break
list $this $that $friends
proc pop2 {listname} {
upvar $listname list
return [splice-ish list -2]
}
set beverages [list Dew Jolt Cola Sprite Fresca]
set pair [pop2 beverages]
list $beverages $pair
set matchIdx [lsearch $list $criterion]
if {$matchIdx >= 0} {
set match [lindex $list $matchIdx]
} else {
}
set matchIdx [lsearch $list $criterion]
if {$matchIdx >= 0} {
} else {
}
Employee is an [incr Tcl] class with the members category,
name, salary, ssn, and age.
lappend employees [Employee lappend employees [Employee lappend employees [Employee foreach employee $employees {
if {[$employee category] eq "engineer"} {
set highestEngineer $employee
break
}
}
$highestEngineer name
package require Tclx
set matching [lmatch [list ab ac bc dk ab] a*]
interp alias {} TEST {} string match a*
set matching [list]
foreach e [list ab ac bc dk ab] {
if {[TEST $e]} {
lappend matching $e
}
}
set matching
set numsorted [lsort -real [list 38 388.7 1.56 279 1e7]]
set descending [lsort -decreasing -real [list 38 388.7 1.56 279 1e7]]
package require Pool_Base
namespace import ::pool::list::apply
set unordered [list 1+7 5-2 3+4]
proc compute e {list [expr $e] $e}
proc second args {lindex $args 1}
set precomputed [apply compute $unordered]
set orderedPrecomputed [lsort -integer -index 0 $precomputed]
set ordered [apply second $orderedPrecomputed]
Employee is an [incr Tcl] class with the members category,
name, salary, ssn, and age.
apply names $employees
set ordered [lsort -command Employee::compare-name $employees]
apply names $ordered
foreach employee [lsort -command Employee::compare-name $employees] {
puts "[$employee name] earns \$[$employee salary]"
}
set sortedEmployees [lsort -command Employee::compare-name $employees]
foreach employee $sortedEmployees {
puts "[$employee name] earns \$[$employee salary]"
}
foreach employee $sortedEmployees {
if {[info exists bonus([$employee ssn])]} {
puts "[$employee name] got a bonus!"
}
}
lappend employees [Employee set sorted [lsort -command Employee::compare-name-or-age $employees]
apply names-and-ages $sorted
set circular [concat [lrange $list 1 end] [lindex $list 0]]
set circular [concat [lindex $list end] [lrange $list 0 end-1]]
proc grabAndRotate {listname} {
upvar $listname list
set first [lindex $list 0]
set list [concat [lrange $list 1 end] $first]
return $first
}
while 1 {
set process [grabAndRotate processes]
puts "Handling process $process"
after 1000
}
proc FisherYatesShuffle {listname} {
upvar $listname list
for {set i [expr {[llength $list]-1}]} {$i >= 0} {incr i -1} {
set j [expr {int(rand()*$i+1)}]
if {$i != $j} {
set temp [lindex $list $i]
set list [lreplace $list $i $i [lindex $list $j]]
set list [lreplace $list $j $j $temp]
}
}
}
proc K {x y} {return $x}
proc shuffle5a { list } {
set n 1
set slist {}
foreach item $list {
set index [expr {int(rand()*$n)}]
set slist [linsert [K $slist [set slist {}]] $index $item]
incr n
}
return $slist
} ;
package require math 1.2
proc n2pat {N len} {
set i 1
set pat [list]
while {$i <= $len + 1} {
lappend pat [expr {$N % $i}]
set N [expr {int($N/$i)}]
incr i
}
return $pat
}
proc pat2perm {args} {
if {[llength $args] == 1} {
set pat [lindex $args 0]
} else {
set pat $args
}
set source [list]
for {set i 0} {$i < [llength $pat]} {incr i} {
lappend source $i
}
set perm [list]
while {[llength $pat]} {
set i [lindex $pat end]
set pat [lrange $pat 0 end-1]
lappend perm [lindex $source $i]
set source [lreplace $source $i $i]
}
return $perm;
}
proc n2perm {N len} {
return [pat2perm [n2pat $N $len]]
}
proc main {} {
while {[gets stdin _] >= 0} {
set data [split $_]
set len [llength $data]
set numPermutations [::math::factorial $len]
for {set i 0} {$i < $numPermutations} {incr i} {
set permutation [list]
foreach {p} [n2perm $i [expr {$len - 1}]] {
lappend permutation [lindex $data $p]
}
puts $permutation
}
}
}
main
array set age {
Nat 24
Jules 25
Josh 17
}
set age(Nat) 24
set age(Jules) 25
set age(Josh) 17
array set foodColor {
Apple red
Banana yellow
Lemon yellow
Carrot orange
}
set array(foo) bar
set key foo
set value bar
set array($key) $value
array set array [list $key $value]
set foodColor(Raspberry) pink
puts "Known foods:"
foreach food {[array names foodColor]} {
puts $food
}
if {[info exists array($key)]} {
} else {
}
foreach name {Banana Martini} {
if {[info exists foodColor($name)]} {
puts "$name is a food."
} else {
puts "$name is a drink.";
}
}
array unset age
set age(Toddler) 3
set age(Unborn) 0
set age(Phantasm) false
foreach thing {Toddler Unborn Phantasm Relic} {
set result "$thing:"
if {[info exists age($thing)]} {
append result " Exists"
if {$age($thing)} {
append result " True"
}
if {$age($thing) != 0} {
append result " Non-zero"
}
}
puts $result
} ;
array unset ARRAY $KEY
proc print-foods {} {
variable foodColor
set foods [array names foodColor]
set food {}
puts "Keys: $foods"
puts -nonewline "Values: "
foreach food $foods {
set color $foodColor($food)
if {$color ne {}} {
puts -nonewline "$color "
} else {
puts -nonewline {(empty) }
}
}
puts {}
}
puts "Initially:"
print-foods
puts "\nWith Banana empty"
set foodColor(Banana) {}
print-foods
puts "\nWith Banana deleted"
array unset foodColor Banana
print-foods
array unset foodColor ?a*
print-foods
foreach {key value} [array get ARRAY] {
}
set searchId [array startsearch ARRAY]
while {[set key [array nextelement ARRAY $searchId]] ne {}} {
set value $ARRAY($key)
}
foreach {food color} [array get foodColor] {
puts "$food is $color."
}
set searchId [array startsearch foodColor]
while {[set food [array nextelement foodColor $searchId]] ne {}} {
set color $foodColor($food)
puts "$food is $color."
}
if {[llength $argv] > 0} {
if {[catch {set f [open [lindex $argv 0]]} err]} {
error $err
}
} else {
set f stdin
}
while {[gets $f line] >= 0} {
if {[regexp {^From: (.*)} $line --> name]} {
if {[info exists from($name)]} {
incr from($name)
} else {
set from($name) 1
}
}
}
if {[array size from] == 0} {
puts "No senders found"
exit
}
foreach person [lsort [array names from]] {
puts "$person: $from($person)"
}
foreach {k v} [array get ARRAY] {
puts "$k => $v"
}
puts [array get ARRAY]
set temp [array get ARRAY]
puts $temp
parray ARRAY
foreach {k} [lsort [array names ARRAY]] {
puts "$k => $ARRAY($k)"
}
array set ttys [list]
set WHO [open "|who"]
while {[gets $WHO line] > -1} {
foreach {user tty} [split $line] break
lappend ttys($user) $tty
}
close $WHO
foreach user [lsort [array names ttys]] {
puts "$user: $ttys($user)"
}
foreach user [lsort [array names ttys]] {
puts "$user: [llength $ttys($user)] ttys."
foreach tty [lsort $ttys($user)] {
if {![catch {file stat /dev/$tty stat}]} {
set user [lindex [getpwuid $stat(uid)] 0]
} else {
set user "(not available)"
}
puts "\t$tty (owned by $user)"
}
}
proc multihash_delete {arrayname key value} {
upvar $arrayname array
set i {}
set len [llength $array($key)]
for {set i 0} {$i < $len} {incr i} {
if {[lindex $array($key) $i] eq $value} {
lset array($key) [lreplace $array($key) $i $i]
break
}
}
if {[llength $array($key)] <= 0} {
array unset array $key
}
}
package require struct 1.4
array set REVERSE [::struct::list reverse [array get LOOKUP]]
package require struct 1.4
proc foodfind foodOrColor {
array set color {
Apple red
Banana yellow
Lemon yellow
Carrot orange
}
array set food [::struct::list reverse [array get color]]
if {[info exists color($foodOrColor)]} {
puts "$foodOrColor is a food with color $color($foodOrColor)."
}
if {[info exists food($foodOrColor)]} {
puts "$food($foodOrColor) is a food with color $foodOrColor."
}
}
foreach {f c} [array get color] {
lappend food($c) $f
}
puts "[join $food(yellow)] were yellow foods."
set keys [lsort OPTIONS [array names a]]
foreach key $keys {
set value $a($key)
}
foreach food [lsort [array names foodColor]] {
puts "$food is $foodColor($food)."
}
proc sortFoods {a b} {
expr {[string length $a] - [string length $b]}
}
foreach food [lsort -command sortFoods [array names foodColor]] {
lappend foods $food
}
foreach food $foods {
puts "$food is $foodColor($food)."
}
array set merged [concat [array get A] [array get B]]
array unset merged
foreach {k v} [array get A] {
set merged($k) $v
}
foreach {k v} [array get B] {
set merged($k) $v
}
array set drinkColor {
Galliano yellow
"Mai Tai" blue
}
array set ingestedColor [concat [array get drinkColor] [array get foodColor]]
array set drinkColor {
Galliano yellow
"Mai Tai" blue
}
array unset ingestedColor
foreach {k v} [array get foodColor] {
set ingestedColor($k) $v
}
foreach {k v} [array get drinkColor] {
set ingestedColor($k) $v
}
foreach substanceref {foodColor drinkColor} {
foreach {k v} [array get $substanceref] {
set substanceColor($k) $v
}
}
foreach substanceref {foodColor drinkColor} {
foreach {k v} [array get $substanceref] {
if {[info exists substanceColor($k)]} {
puts "Warning: $k seen twice. Using the first definition."
continue
}
set substanceColor($k) $v
}
}
set common {}
foreach k [array names arr1] {
if {[info exists arr2($k)]} {
lappend common $k
}
}
set thisNotThat {}
foreach k [array names arr1] {
if {![info exists arr2($k)]} {
lappend thisNotThat $k
}
}
array set citrusColor {
Lemon yellow
Orange orange
Lime green
}
set nonCitrus {}
foreach k [array names foodColor] {
if {![info exists citrusColor($k)]} {
lappend nonCitrus $k
}
}
array unset count
foreach element $LIST {
if {![info exists count($element)]} {
set count($element) 1
} else {
incr count($element)
}
}
array set father {
Cain Adam
Abel Adam
Seth Adam
Enoch Cain
Irad Enoch
Mehujael Irad
Methusael Mehujael
Lamech Methusael
Jabal Lamech
Jubal Lamech
Tubalcain Lamech
Enos Seth
}
foreach name {Adam Tubalcain Elvis Enos} {
set fathers {}
while {[info exists father($name)]} { ; lappend fathers $name ; set name $father($name) ; }
puts $fathers
}
foreach {k v} [array get father] {
lappend children($v) $k
}
set sep {, } ;foreach name {Adam Tubalcain Elvis Lamech} {
if {[info exists children($name)] && [llength children($name)]} {
set res $children($name)
} else {
set res nobody
}
puts "$name begat [join $res $sep]"
}
foreach file $files {
if {[catch {open $file} F]} {
puts stderr "Couldn't read $file: $F; skipping."
continue
}
while {[gets $F line] >= 0} {
if {![regexp {^\s* continue
}
lappend includes($name) $file
}
close $F
}
set includeFree {} ;foreach k [array names includes] {
set uniq($k) {}
}
forech file [lsort [array names uniq]] {
if {![info exists includes($file)]} {
lappend includeFree $file
}
}
regexp $pattern $string
regsub $pattern $string $replacement
regexp sheep $meadow
regsub old $meadow new meadow
if [regexp -nocase {\bovines?\b} $meadow ] {
puts -nonewline {Here be sheep!}
}
set string {good food}
set string [regsub {o*} $string e]
foreach i [regexp -all -inline {\d+}] {
puts "Found number $i"
}
set numbers [regexp -all -inline {\d+}]
set digits 123456789
set nonlap [regexp -inline -all {\d\d\d} $digits]
set yeslap {}
for {set i 0} {$i < [string length $digits]} {incr i} {
set match [regexp -inline {\d\d\d} [string range $digits $i end]]
if {[string length $match]} {
lappend yeslap $match
}
}
set string {And little lambs eat ivy}
regexp -indices -- {l.*s} $string idxs
set start [lindex $idxs 0]
set stop [lindex $idxs 1]
puts "([string range $string 0 $start-1]) ([string range $string $start $stop]) ([string range $string $stop+1 end])"
set dst $src
regsub this $dst that dst
regsub this $src that dst
regsub ^.*/ $::argv0 {} progname
package require struct::list
::struct::list map $words {string totitle}
set capword [gregsub {(\w+)} $words {
r {return [string totitle $r]}
}]
regsub {man(?=\d)} $manpage cat catpage
set bindirs {/usr/bin /bin /usr/local/bin}
set libdirs [string map {bin lib} $bindirs]
puts $libdirs
regsub -all x $a y b set b [regsub -all x $a y a]
if [regexp {^[A-Za-z]+$} $var] {
}
if [regexp {^[[:alpha:]]+$} $var] {
puts "var is purely alphabetic"
}
readlines $data {
{line} {
if {[regexp {^[[:alpha:]]+$} $line]} {
puts -nonewline "$line: alphabetic"
} else {
puts -nonewline "$line: line noice"
}
}
}
{\S+} {[A-Za-z'-]+}
{\y([A-Za-z]+)\y} {\s([A-Za-z]+)\s}
package require Tclx
set str {www.tcl.tk}
set re {(?x) ( (?: (?! [-_] ) [\w] + \. )+ [A-Za-z] [\w-]+ )
}
puts [gregsub $re $str {
{host} {
return "$host \[[host_info addresses $host]\]"
}
}]
set re {(?x) \# (\w+) \# }
puts [gregsub $re $str {
{var} {
return [uplevel 2 "set $var"]
}
}]
set pond "One fish two fish red fish blue fish"
set want 3
set count 0
gregsub {(?i)(\w+)\s+fish} $pond {
{c} {
variable want
variable count
incr count
if {$want == $count} {
puts "The third fish is a $c one"
}
}
}
set fishes [regexp -all -inline -- {(?i)\w+(?=\s+fish)} $pond ]
puts "The third fish is a [lindex $fishes 2] one."
{(?i)(?:\w+\s+fish\s+){2}(\w+)\s+fish}
set count 0
gregsub {(?i)(\w+)\s+fish} $pond {
{c} {
uplevel 2 {incr count} }
}
set count [regsub -all -- {PAT} $string {} {}]
set count [expr [llength [regexp -all -- {PAT} $string]] + 1]
set colors [regexp -all -inline -- {(?i)\w+(?=\s+fish)} $pond ]
set color [lindex $colors 2]
set color [lindex [regexp -all -inline -- {(?i)\w+(?=\s+fish)} $pond ] 2]
puts "The third fish in the pond is $color"
set evens {}
foreach {a b} [regexp -all -inline -- {(?i)\w+(?=\s+fish)} $pond ] {
lappend evens $b
}
puts "The even numbered fish are $evens"
set pond "One fish two fish red fish blue fish swim here"
set color [lindex [regexp -all -inline -- {(?i)\w+(?=\s+fish)} $pond ] end]
puts "Last fish is $color"
set re {(?x)
A (?! .* A )
$ }
set pond "One fish two fish red fish blue fish swim here"
if [regexp -- {(?x)
\y(\w+)\s+fish\y
(?!.*\yfish\y)
} $pond all one] {
puts "Last fish is $one"
} else {
puts "Failed."
}
argf-iter {
line {
puts [regsub -all -- {<.*>} $line {}]
}
}
set re {(?xn)
\A (
^Chapter \s+
\d+ \s+
:
.*
)$
}
set options(CR) "\n"
argf-iter {
para {
variable re
puts -nonewline [regsub -all -- $re $para {<H1>\1</H1>}]
}
}
array unset options(CR)
set options(CR) "\n\n"
argf-iter {
para {
gregsub {(?w)^START(.*?)^END} $para {
{chunk} {
puts -nonewline "chunk in $::argv has $chunk"
}
}
}
}
set chunks [split [regsub -all -- {pattern} [read -nonewline $fd] "\0"] "\0"]
set chunks [split [regsub -all -- {(?n)^\.(Ch|Se|Ss)$} [read -nonewline $fd] "\0"] "\0"]
set len [llength $chunks]
puts "I read $len chunks"
set fd [open $argv]
set data [split [read $fd] "\n"]
regrange {BEGIN PATTERN} .. {ENDPATTERN} $data {
{line} {
puts ">$line"
}
}
set fd [open $argv]
set data [split [read $fd] "\n"]
foreach line [lrange $data $first_line_no $last_line_no-1] {
puts $line
}
set fd [open $argv]
set data [split [read $fd] "\n"]
regrange {BEGIN PATTERN} ... {ENDPATTERN} $data {
{line} {
puts ">$line"
}
}
set fd [open $argv]
set data [split [read $fd] "\n"]
foreach line [lrange $data $first_line_no-1 $last_line_no] {
puts $line
}
set fd [open $argv]
set data [split [read $fd] "\n"]
puts [lrange $data 15-1 17-1]
set in_header {}
regrange {} .. {^$} $data {
{line} {
variable in_header
lappend in_header $line
}
}
set in_body {}
regrange {^$} .. {$-^} $data { {line} {
variable in_body
lappend in_body $line
}
}
set fd [open $argv]
set data [split [read $fd] "\n"]
array set seen {}
regrange {(?i)^From:?\s} .. {^$} $data {
line {
variable seen
set ids [regexp -inline -all {[^<>(),;\s]+\@[^<>(),;\s]+} $line]
foreach id $ids {
if {![info exists seen($id)]} {
puts $id
set seen($id) 0
} else {
incr seen($id)
}
}
}
}
proc glob2pat globstr {
set patmap {
"\\" "\\\\"
{.} {\.}
{+} {\+}
{^} {\^}
{$} {\$}
"{" "\{"
"}" "\}"
{(} {\(}
{)} {\)}
* .*
? .
[ [
] ]
}
return [append {} (?b)^ [string map $patmap [join $globstr]] $]
}
set pattern {blue}
argf-iter {
line {
variable pattern
if [regexp -- $pattern $line] {
}
}
}
set popstates {CO ON MI WI MN}
while {[gets $fd line] >= 0} {
foreach state $popstates {
if [regexp -- $state $line] {
puts $line
break
}
}
}
set popstates {CO ON MI WI MN}
argf-iter {
line {
variable popstates
foreach state $popstates {
if [regexp -- $state $line] {
puts -nonewline $line
break
}
}
}
}
set popstates {CO ON MI WI MN}
set pre {while {[gets $fd line]>= 0}}
set code {}
foreach state $popstates {
append code [subst -nocommands {
if [regexp -- $state [set line]] {
puts [set line]
}
}]
}
eval [lappend pre $code]
package require struct::list
set fd [open $argv]
set sw_pre {[switch -regexp {$line}}
set code {}
append code [::struct::list map $popstates {apply {
{state} {
return "$state {return 1}"
}
}}]
lappend code {default {return 0}}
set tmp {}
set myproc [append tmp $sw_pre { } [list [join $code]] {]}]
while {[gets $fd line] >= 0} {
if [subst [subst -nocommands $myproc]] {
puts $line
}
}
proc build_exp words {
return [::struct::list map $words {apply
{{word} {
return "line {return \[regexp $word \$line\]}"
}}
}]
}
proc func {var f} {
return [apply $f $var]
}
proc + {a b} {return [expr ($a + $b)]}
proc * {a b} {return [expr ($a * $b)]}
proc build_match_func {func init words} {
return "line {return \[::struct::list fold \[::struct::list map \[build_exp {$words}\] \[list func \$line\]\] $init $func\]}"
}
set match_any [build_match_func + 0 $words]
set match_all [build_match_func * 1 $words]
while {[gets $fd line] >= 0} {
if [apply $match_all $line] {
puts $line
}
}
set popstates {CO ON MI WI MN}
while {[gets $fd line] >= 0} {
foreach state $popstates {
if [regexp -- $state $line] {
puts $line
break
}
}
}
chan configure stdout -buffering none
while {![eof stdin]} {
if {[catch {
puts -nonewline "Pattern? "
gets stdin pat
regexp $pat {}
} err]} {
puts "Invalid pattern"
}
}
proc is_valid_pattern pat {
return [expr ![catch {regexp $pat {}} err]]
}
set rexp [lindex $argv 0]
if [catch "regexp $rexp {}" err] {
puts "Bad Pattern $rexp: $::argv0"
exit -1
}
set fd [open [lindex $argv 1]]
foreach para [split [regsub -all -- "\n\n" [read $fd] "\0"] "\0"] {
if [regexp $rexp $para] {
puts $para
}
}
close $fd
set safe [interp create -safe]
if [$safe eval {regexp $pat $line}] {
do_something
}
gregsub {(\d+)} $str {
{match} {
puts "Found $match"
}
}
set n [gregsub {^( )} $str {
{match} {
return 0
}
}]
gregsub {^,?(\d+)} $str {
{match} {
puts "Found number $match"
}
}
proc gmatch {exp str block} {
set start 0
while 1 {
if {[regexp -indices -start $start -- $exp $str idx]} {
set start [expr [lindex $idx 1] + 1]
apply $block [string range $str {expand}$idx]
} else break
}
return $start
}
set str "The year 1752 lost 10 days on the 3rd of September"
set e [gmatch {\d+} $str {
{match} {
puts $match
}
}]
if [regexp -indices -start $e -- {\S+} $str idx] {
puts "Found [string range $str {expand}$idx] after last number"
}
regsub -all -- {<.*>} $line {} line
regsub -all -- {<.*?>} $line {} line
set txt "<b><i>this</i> and <i>that</i> are important</b> Oh, <b><i>me
too!</i></b>"
regexp -all -inline -- {(?x) <b><i>(.*?)</i></b> } $txt
{(?x)BEGIN((?:(?!BEGIN).)*)END}
{(?x) <b><i>( (?: (?!</b>|</i>). )* )</i></b> }
{(?x) <b><i>( (?: (?!</[bi]>). )* )</i></b> }
{(?x)
<b><i>
[^<]* (?:
(?! </?[ib]> ) <
[^>]*
) *
</i></b>
}
set fd [open $argv]
set p 0
foreach para [split [regsub -all -- "\n\n" [read -nonewline $fd] "\0"] "\0"] {
incr p
set start 0
while 1 {
set re {\y(\S+)\y(\s+\1\y)}
if {[regexp -indices -start $start -- $re $para all one two]} {
puts "dup word '[string range $para {expand}$one]' at paragraph $p"
set start [expr [lindex $all end] + 1]
} else break
}
}
set a nobody
set b bodysnatcher
if [regexp -- {^(\w+)(\w+) \2(\w+)$} "$a $b" all 1 2 3] {
puts "$2 overlaps in $1-$2-$3"
}
{^(\w+?)(\w+) \2(\w+)$}
set arg 180
set cap [string repeat o $arg]
while {[regexp -- {^(oo+?)\1+$} $cap all one]} {
puts -nonewline [string length $one]
regsub -all $one $cap o cap
}
puts [string length $cap]
set cap [string repeat o 281]
if {[regexp -- {(o*)\1{11}(o*)\2{14}(o*)\3{15}$} [string repeat o 281]
all 1 2 3]} {
puts "One solution is x=[string length $1] y=[string length $2]
z=[string length $3]"
} else {
puts "No match"
}
{^(o+)\1{11}(o+)\2{14}(o+)\3{15}$} => One solution is x=17 y=3 z=2
{^(o*?)\1{11}(o*)\2{14}(o*)\3{15}$} => One solution is x=0 y=7 z=11
{^(o+?)\1{11}(o*)\2{14}(o*)\3{15}$} => One solution is x=1 y=3 z=14
{alpha|beta}
{(?=.*alpha)(?=.*beta)}
{alpha.*beta|beta.*alpha}
{^(?:(?!beta).)*$}
{(?=(?:(?!BAD).)*$)GOOD}
if {[expr [regexp {pat1} $string] && [regexp {pat2} $string]]} {
something
}
if {[expr [regexp {pat1} $string] || [regexp {pat2} $string]]} {
something
}
set pat [::struct::list shift argv]
argf-iter {
line {
variable pat
if [regexp $pat $line] {
puts -nonewline $line
}
}
}
regexp {(?=.*bell)(?=.*lab)} "labelled"
[expr {[regexp {} bell] && [regexp {} lab]}]
if [regexp {(?xw)
^ (?= .*
bell
)
(?=
.*
lab
)
} $murray_hill] {
puts "Looks like Bell Labs might be in Murray Hill!"
}
regexp {(?:^.*bell.*lab)|(?:^.*lab.*bell)} labelled
set brand labelled
if [regexp {(?xw)
(?: