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, 0 insertions, 266 deletions
diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl
deleted file mode 100644
index d43cd4e..0000000
--- a/tools/regexpTestLib.tcl
+++ /dev/null
@@ -1,266 +0,0 @@
-# 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-10-02 14:36:35 (GMT)