Arjen Markus (18 february 2003) I wanted a good, concise script that shows what Tcl is good at. That is, a script that performs tasks that are difficult or awkward in system programming languages or require lots of code.
The script below uses the following techniques:
What it does is this:
It could be enhanced with lots of extra options, manoeuvre through the directory tree, and so on. But to get people at least somewhat familiar with the techniques, this script (170 lines including comments) is adequate - I hope.
# agrep.tcl --
# Script to emulate the UNIX grep command with a small GUI
#
# createWindow --
# Create the main window
#
# Arguments:
# None
# Result:
# None
# Side effects:
# Controls added to main window
#
proc createWindow {} {
global filemask
global pattern
global ignore_case
#
# Menubar (simple)
#
frame .menubar -relief raised -borderwidth 1
pack .menubar -side top -fill x
menubutton .menubar.file -text File -menu .menubar.file.menu
menu .menubar.file.menu -tearoff false
.menubar.file.menu add command -label Exit -command exit
pack .menubar.file -side left
#
# Fill in fields
#
frame .f1
label .f1.empty -text " "
label .f1.mask_label -text "Files:" -justify left
label .f1.patt_label -text "Regular expression:" -justify left
entry .f1.filemask -textvariable filemask
entry .f1.pattern -textvariable pattern
checkbutton .f1.ignore_case -variable ignore_case -text "Ignore case"
button .f1.search -command searchFiles -text "Search"
grid .f1.empty x x
grid .f1.mask_label .f1.filemask .f1.search -sticky w
grid .f1.patt_label .f1.pattern .f1.ignore_case -sticky w
pack .f1 -side top -fill x
#
# Result window
#
frame .f2
text .f2.text -font "Courier 10" \
-yscrollcommand {.f2.y set} \
-xscrollcommand {.f2.x set}
scrollbar .f2.x -command {.f2.text xview} -orient horizontal
scrollbar .f2.y -command {.f2.text yview}
grid .f2.text .f2.y -sticky ns
grid .f2.x x -sticky we
pack .f2 -side top
#
# Just for the fun of it: define the styles for the "matched",
# "error" and "fn" tags
#
.f2.text tag configure "matched" -underline 1 -background yellow
.f2.text tag configure "fn" -underline 1 -background lightblue
.f2.text tag configure "error" -background red
}
# searchFiles --
# Search for files in the current directory that match the given
# mask
#
# Arguments:
# None
# Result:
# None
# Side effects:
# Calls "searchPattern" to fill the result window
#
proc searchFiles {} {
global filemask
global pattern
global ignore_case
#
# Clear the result window, then get a list of files
#
.f2.text delete 0.1 end
if { $filemask == "" } {
set filemask "*"
}
foreach file [glob $filemask] {
if { [file isdirectory $file] } {
continue ;# Might become a recursive descent later :)
} else {
searchPattern $file $pattern $ignore_case
}
}
}
# searchPattern --
# Search for lines containing the given pattern in a file
#
# Arguments:
# filename Name of the file to be searched
# pattern Given regular expression
# ignore_case Ignore the case or not
# Result:
# None
# Side effects:
# Fills the result window
#
proc searchPattern {filename pattern ignore_case} {
if { [ catch {
set infile [open $filename "r"]
.f2.text insert end "$filename:\n" fn
while { [gets $infile line] >= 0 } {
if { $ignore_case } {
set match [regexp -nocase -indices -- $pattern $line indices]
} else {
set match [regexp -indices -- $pattern $line indices]
}
if { $match } {
set first [lindex $indices 0]
set last [lindex $indices 1]
.f2.text insert end [string range $line 0 [expr {$first-1}]]
.f2.text insert end [string range $line $first $last] "matched"
.f2.text insert end [string range $line [expr {$last+1}] end]
.f2.text insert end "\n"
}
}
close $infile
} msg ] } {
.f2.text insert end "$msg\n"
}
.f2.text insert end "\n"
}
# main --
# Main code to get it all going
#
global filemask
global pattern
global ignore_case
set filemask "*"
set pattern {}
set ignore_case 1
createWindow
see also grep.
see also Hits! [L1 ]
TV I'm not sure it is superfluous, but bwise for a long time had this one packed with it:
proc grep { {a} {fs {*}} } {
set o {}
foreach n [lsort -incr -dict [glob $fs]] {
set f [open $n r]
set c 0
set new 1
while {[eof $f] == 0} {
set l [gets $f]
incr c
if {[string first $a $l] > -1} {
if {$new == 1} {set new 0; append o "*** $n:" \n}
append o "$c:$l" \n
}
}
close $f
}
return $o
}The variable which contains the return value is formatted to be OK in a shell or console, but can easily be computer formatted too. Efficiency was fine on older PC's. It errs on subdirs when they match the search pattern I just came up with, but it is small.