diff options
Diffstat (limited to 'tools/spencer2regexp.tcl')
| -rw-r--r-- | tools/spencer2regexp.tcl | 174 |
1 files changed, 174 insertions, 0 deletions
diff --git a/tools/spencer2regexp.tcl b/tools/spencer2regexp.tcl new file mode 100644 index 0000000..b23f806 --- /dev/null +++ b/tools/spencer2regexp.tcl @@ -0,0 +1,174 @@ +# spencer2regexp.tcl -- +# +# This file generates a test suite for the regexp command based on +# Henry Spencer's test suite. This script must be run in tcl 8.1 or +# higher and takes an output filename as its parameter. +# +# Copyright (c) 1996 by Sun Microsystems, Inc. +# +# SCCS: @(#) spencer2regexp.tcl 1.4 98/01/22 14:48:09 +# + +source ../tools/regexpTestLib.tcl + +# +# remove flags that have no meaning +# +proc removeFlags {flags} { + regsub -all {a|s|&|-|/|\+|,|\$|;|:|>|=|\.|\[|[A-Z]|[0-9]} $flags "" newFlags + return $newFlags +} + +# +# NOTBOL flag is already tested and can't be tested from the command line, skip ^ +# L is locale dependant, skip L +# $ flag has no (?$) meaning +# b&a and q&e are bad flag combinations +# +proc findSkipFlag {flags} { + if {[string first "^" $flags] != -1} { + return 1 + } + if {([string first "q" $flags] != -1) + && ([string first "e" $flags] != -1)} { + return 1 + } + if {([string first "a" $flags] != -1) + && ([string first "b" $flags] != -1)} { + return 1 + } + if {[regexp {\$|\+} $flags] == 1} { + return 1 + } + return 0 +} + +proc prepareCmd {flags re str vars noBraces} { + # adjust the re to include to compile-time flag, where applicable + + if {[llength $flags] != 0} { + + # if re already has meta-syntax, skip this test + + if {[regexp {^(\(\?)|^(\*\*\*)} $re] == 1} { + return -1 + } + set re "\(?$flags\)$re" + } + if {$noBraces > 0} { + set cmd "regexp -- $re $str $vars" + } else { + set cmd "regexp -- [list $re] [list $str] $vars" + } + return $cmd +} + +proc convertTestLineJunk {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 + + 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 + regsub -all {R} $currentLine {\\r} 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 result "0 \{1 [removeAts [lrange $currentLine 3 $len]]\}" + } + } else { + # no match is made + + set result "0 0" + } + + # adjust the re to include to compile-time flag, where applicable + + if {[llength $flags] != 0} { + + # if re already has meta-syntax, skip this test + + if {[regexp {^(\(\?)|^(\*\*\*)} $re] == 1} { + return "\# skipping test with metasyntax from line $srcLineNum\n" + } + set re "\(?$flags\)$re" + } + + # set up the test and write it to the output file + + set cmd "regexp -- [list $re] [list $str] $vars" + 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 +} + +# main + +if {$argc != 2} { + puts "name of input and outfile reuqired" + return +} + +set inFileName [lindex $argv 0] +set outFileName [lindex $argv 1] + +writeOutputFile [readInputFile] regexp |