summaryrefslogtreecommitdiffstats
path: root/tools/regexpTestLib.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tools/regexpTestLib.tcl')
-rw-r--r--tools/regexpTestLib.tcl266
1 files changed, 266 insertions, 0 deletions
diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl
new file mode 100644
index 0000000..d43cd4e
--- /dev/null
+++ b/tools/regexpTestLib.tcl
@@ -0,0 +1,266 @@
+# regexpTestLib.tcl --
+#
+# This file contains tcl procedures used by spencer2testregexp.tcl and
+# spencer2regexp.tcl, which are programs written to convert Henry
+# Spencer's test suite to tcl test files.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+#
+# SCCS: @(#) regexpTestLib.tcl 1.4 98/01/22 14:48:34
+#
+
+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
+}
+
+#
+# strings with embedded @'s are truncated
+# unpreceeded @'s are replaced by {}
+#
+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
+
+ # open output file and write file header info to it.
+
+ 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)
+
+ # copy comment string to output file and continue
+
+ if {[string index $currentLine 0] == "#"} {
+ puts $fileId $currentLine
+ incr srcLineNum $lineArray(c$lineNum)
+ incr lineNum
+ continue
+ }
+
+ set len [llength $currentLine]
+
+ # copy empty string to output file and continue
+
+ 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]
+
+ # based on flags, decide whether to skip the test
+
+ if {[findSkipFlag $flags]} {
+ regsub -all {\[|\]|\(|\)|\{|\}|\#} $currentLine {\&} line
+ set msg "\# skipping char mapping test from line $srcLineNum\n"
+ append msg "print \{... skip test from line $srcLineNum: $line\}"
+ return $msg
+ }
+
+ # perform mapping if '=' flag exists
+
+ 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
+
+ # if and \r substitutions are made, do not wrap re, flags,
+ # str, and result in braces
+
+ 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]
+
+ # find the test result
+
+ set numVars [expr $len - 3]
+ set vars {}
+ set vals {}
+ set result 0
+ set v 0
+
+ if {[regsub {\*} "$flags" "" newFlags] == 1} {
+ # an error is expected
+
+ if {[string compare $str "EMPTY"] == 0} {
+ # empty regexp is not an error
+ # skip this test
+
+ return "\# skipping the empty-re test from line $srcLineNum\n"
+ }
+ set flags $newFlags
+ set result "\{1 \{[convertErrCode $str]\}\}"
+ } elseif {$numVars > 0} {
+ # at least 1 match is made
+
+ 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 {
+ # no match is made
+
+ set result "\{0 0\}"
+ }
+
+ # set up the test and write it to the output file
+
+ 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
+}
+
generated by cgit v0.12 at 2024-11-19 00:25:52 (GMT)