proc readInputFile {} {
global inFileName
global lineArray
set fileId [open $inFileName r]
set i 0
while {[gets $fileId line] >= 0} {
set len [string length $line]
if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} {
if {[info exists lineArray(c$i)] == 0} {
set lineArray(c$i) 1
} else {
incr lineArray(c$i)
}
set line [string range $line 0 [expr $len - 2]]
append lineArray($i) $line
continue
}
if {[info exists lineArray(c$i)] == 0} {
set lineArray(c$i) 1
} else {
incr lineArray(c$i)
}
append lineArray($i) $line
incr i
}
close $fileId
return $i
}
proc removeAts {ls} {
set len [llength $ls]
set newLs {}
foreach item $ls {
regsub @.* $item "" newItem
lappend newLs $newItem
}
return $newLs
}
proc convertErrCode {code} {
set errMsg "couldn't compile regular expression pattern:"
if {[string compare $code "INVARG"] == 0} {
return "$errMsg invalid argument to regex routine"
} elseif {[string compare $code "BADRPT"] == 0} {
return "$errMsg ?+* follows nothing"
} elseif {[string compare $code "BADBR"] == 0} {
return "$errMsg invalid repetition count(s)"
} elseif {[string compare $code "BADOPT"] == 0} {
return "$errMsg invalid embedded option"
} elseif {[string compare $code "EPAREN"] == 0} {
return "$errMsg unmatched ()"
} elseif {[string compare $code "EBRACE"] == 0} {
return "$errMsg unmatched {}"
} elseif {[string compare $code "EBRACK"] == 0} {
return "$errMsg unmatched \[\]"
} elseif {[string compare $code "ERANGE"] == 0} {
return "$errMsg invalid character range"
} elseif {[string compare $code "ECTYPE"] == 0} {
return "$errMsg invalid character class"
} elseif {[string compare $code "ECOLLATE"] == 0} {
return "$errMsg invalid collating element"
} elseif {[string compare $code "EESCAPE"] == 0} {
return "$errMsg invalid escape sequence"
} elseif {[string compare $code "BADPAT"] == 0} {
return "$errMsg invalid regular expression"
} elseif {[string compare $code "ESUBREG"] == 0} {
return "$errMsg invalid backreference number"
} elseif {[string compare $code "IMPOSS"] == 0} {
return "$errMsg can never match"
}
return "$errMsg $code"
}
proc writeOutputFile {numLines fcn} {
global outFileName
global lineArray
set fileId [open $outFileName w]
puts $fileId "# Commands covered: $fcn"
puts $fileId "#"
puts $fileId "# This Tcl-generated file contains tests for the $fcn tcl command."
puts $fileId "# Sourcing this file into Tcl runs the tests and generates output for"
puts $fileId "# errors. No output means no errors were found. Setting VERBOSE to"
puts $fileId "# -1 will run tests that are known to fail."
puts $fileId "#"
puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc."
puts $fileId "#"
puts $fileId "# See the file \"license.terms\" for information on usage and redistribution"
puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES."
puts $fileId "#"
puts $fileId "\# SCCS: \%Z\% \%M\% \%I\% \%E\% \%U\%"
puts $fileId "\nproc print \{arg\} \{puts \$arg\}\n"
puts $fileId "if \{\[string compare test \[info procs test\]\] == 1\} \{"
puts $fileId " source defs ; set VERBOSE -1\n\}\n"
puts $fileId "if \{\$VERBOSE != -1\} \{"
puts $fileId " proc print \{arg\} \{\}\n\}\n"
puts $fileId "#"
puts $fileId "# The remainder of this file is Tcl tests that have been"
puts $fileId "# converted from Henry Spencer's regexp test suite."
puts $fileId "#\n"
set lineNum 0
set srcLineNum 1
while {$lineNum < $numLines} {
set currentLine $lineArray($lineNum)
if {[string index $currentLine 0] == "#"} {
puts $fileId $currentLine
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
continue
}
set len [llength $currentLine]
if {$len == 0} {
puts $fileId "\n"
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
continue
}
if {($len < 3)} {
puts "warning: test is too short --\n\t$currentLine"
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
continue
}
puts $fileId [convertTestLine $currentLine $len $lineNum $srcLineNum]
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
}
close $fileId
}
proc convertTestLine {currentLine len lineNum srcLineNum} {
regsub -all {(?b)\\} $currentLine {\\\\} currentLine
set re [lindex $currentLine 0]
set flags [lindex $currentLine 1]
set str [lindex $currentLine 2]
if {[findSkipFlag $flags]} {
regsub -all {\[|\]|\(|\)|\{|\}|\ set msg "\# skipping char mapping test from line $srcLineNum\n"
append msg "print \{... skip test from line $srcLineNum: $line\}"
return $msg
}
set noBraces 0
if {[regexp {=|>} $flags] == 1} {
regsub -all {_} $currentLine {\\ } currentLine
regsub -all {A} $currentLine {\\007} currentLine
regsub -all {B} $currentLine {\\b} currentLine
regsub -all {E} $currentLine {\\033} currentLine
regsub -all {F} $currentLine {\\f} currentLine
regsub -all {N} $currentLine {\\n} currentLine
set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine]
regsub -all {T} $currentLine {\\t} currentLine
regsub -all {V} $currentLine {\\v} currentLine
if {[regexp {=} $flags] == 1} {
set re [lindex $currentLine 0]
}
set str [lindex $currentLine 2]
}
set flags [removeFlags $flags]
set numVars [expr $len - 3]
set vars {}
set vals {}
set result 0
set v 0
if {[regsub {\*} "$flags" "" newFlags] == 1} {
if {[string compare $str "EMPTY"] == 0} {
return "\# skipping the empty-re test from line $srcLineNum\n"
}
set flags $newFlags
set result "\{1 \{[convertErrCode $str]\}\}"
} elseif {$numVars > 0} {
if {[regexp {s} $flags] == 1} {
set result "\{0 1\}"
} else {
while {$v < $numVars} {
append vars " var($v)"
append vals " \$var($v)"
incr v
}
set tmp [removeAts [lrange $currentLine 3 $len]]
set result "\{0 \{1 $tmp\}\}"
if {$noBraces} {
set result "\[subst $result\]"
}
}
} else {
set result "\{0 0\}"
}
set cmd [prepareCmd $flags $re $str $vars $noBraces]
if {$cmd == -1} {
return "\# skipping test with metasyntax from line $srcLineNum\n"
}
set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n"
append test "\tcatch {unset var}\n"
append test "\tlist \[catch \{ \n"
append test "\t\tset match \[$cmd\] \n"
append test "\t\tlist \$match $vals \n"
append test "\t\} msg\] \$msg \n"
append test "\} $result \n"
return $test
}