1# regexpTestLib.tcl -- 2# 3# This file contains tcl procedures used by spencer2testregexp.tcl and 4# spencer2regexp.tcl, which are programs written to convert Henry 5# Spencer's test suite to tcl test files. 6# 7# Copyright (c) 1996 by Sun Microsystems, Inc. 8# 9# SCCS: @(#) regexpTestLib.tcl 1.4 98/01/22 14:48:34 10# 11 12proc readInputFile {} { 13 global inFileName 14 global lineArray 15 16 set fileId [open $inFileName r] 17 18 set i 0 19 while {[gets $fileId line] >= 0} { 20 21 set len [string length $line] 22 23 if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} { 24 if {[info exists lineArray(c$i)] == 0} { 25 set lineArray(c$i) 1 26 } else { 27 incr lineArray(c$i) 28 } 29 set line [string range $line 0 [expr $len - 2]] 30 append lineArray($i) $line 31 continue 32 } 33 if {[info exists lineArray(c$i)] == 0} { 34 set lineArray(c$i) 1 35 } else { 36 incr lineArray(c$i) 37 } 38 append lineArray($i) $line 39 incr i 40 } 41 42 close $fileId 43 return $i 44} 45 46# 47# strings with embedded @'s are truncated 48# unpreceeded @'s are replaced by {} 49# 50proc removeAts {ls} { 51 set len [llength $ls] 52 set newLs {} 53 foreach item $ls { 54 regsub @.* $item "" newItem 55 lappend newLs $newItem 56 } 57 return $newLs 58} 59 60proc convertErrCode {code} { 61 62 set errMsg "couldn't compile regular expression pattern:" 63 64 if {[string compare $code "INVARG"] == 0} { 65 return "$errMsg invalid argument to regex routine" 66 } elseif {[string compare $code "BADRPT"] == 0} { 67 return "$errMsg ?+* follows nothing" 68 } elseif {[string compare $code "BADBR"] == 0} { 69 return "$errMsg invalid repetition count(s)" 70 } elseif {[string compare $code "BADOPT"] == 0} { 71 return "$errMsg invalid embedded option" 72 } elseif {[string compare $code "EPAREN"] == 0} { 73 return "$errMsg unmatched ()" 74 } elseif {[string compare $code "EBRACE"] == 0} { 75 return "$errMsg unmatched {}" 76 } elseif {[string compare $code "EBRACK"] == 0} { 77 return "$errMsg unmatched \[\]" 78 } elseif {[string compare $code "ERANGE"] == 0} { 79 return "$errMsg invalid character range" 80 } elseif {[string compare $code "ECTYPE"] == 0} { 81 return "$errMsg invalid character class" 82 } elseif {[string compare $code "ECOLLATE"] == 0} { 83 return "$errMsg invalid collating element" 84 } elseif {[string compare $code "EESCAPE"] == 0} { 85 return "$errMsg invalid escape sequence" 86 } elseif {[string compare $code "BADPAT"] == 0} { 87 return "$errMsg invalid regular expression" 88 } elseif {[string compare $code "ESUBREG"] == 0} { 89 return "$errMsg invalid backreference number" 90 } elseif {[string compare $code "IMPOSS"] == 0} { 91 return "$errMsg can never match" 92 } 93 return "$errMsg $code" 94} 95 96proc writeOutputFile {numLines fcn} { 97 global outFileName 98 global lineArray 99 100 # open output file and write file header info to it. 101 102 set fileId [open $outFileName w] 103 104 puts $fileId "# Commands covered: $fcn" 105 puts $fileId "#" 106 puts $fileId "# This Tcl-generated file contains tests for the $fcn tcl command." 107 puts $fileId "# Sourcing this file into Tcl runs the tests and generates output for" 108 puts $fileId "# errors. No output means no errors were found. Setting VERBOSE to" 109 puts $fileId "# -1 will run tests that are known to fail." 110 puts $fileId "#" 111 puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc." 112 puts $fileId "#" 113 puts $fileId "# See the file \"license.terms\" for information on usage and redistribution" 114 puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES." 115 puts $fileId "#" 116 puts $fileId "\# SCCS: \%Z\% \%M\% \%I\% \%E\% \%U\%" 117 puts $fileId "\nproc print \{arg\} \{puts \$arg\}\n" 118 puts $fileId "if \{\[string compare test \[info procs test\]\] == 1\} \{" 119 puts $fileId " source defs ; set VERBOSE -1\n\}\n" 120 puts $fileId "if \{\$VERBOSE != -1\} \{" 121 puts $fileId " proc print \{arg\} \{\}\n\}\n" 122 puts $fileId "#" 123 puts $fileId "# The remainder of this file is Tcl tests that have been" 124 puts $fileId "# converted from Henry Spencer's regexp test suite." 125 puts $fileId "#\n" 126 127 set lineNum 0 128 set srcLineNum 1 129 while {$lineNum < $numLines} { 130 131 set currentLine $lineArray($lineNum) 132 133 # copy comment string to output file and continue 134 135 if {[string index $currentLine 0] == "#"} { 136 puts $fileId $currentLine 137 incr srcLineNum $lineArray(c$lineNum) 138 incr lineNum 139 continue 140 } 141 142 set len [llength $currentLine] 143 144 # copy empty string to output file and continue 145 146 if {$len == 0} { 147 puts $fileId "\n" 148 incr srcLineNum $lineArray(c$lineNum) 149 incr lineNum 150 continue 151 } 152 if {($len < 3)} { 153 puts "warning: test is too short --\n\t$currentLine" 154 incr srcLineNum $lineArray(c$lineNum) 155 incr lineNum 156 continue 157 } 158 159 puts $fileId [convertTestLine $currentLine $len $lineNum $srcLineNum] 160 161 incr srcLineNum $lineArray(c$lineNum) 162 incr lineNum 163 } 164 165 close $fileId 166} 167 168proc convertTestLine {currentLine len lineNum srcLineNum} { 169 170 regsub -all {(?b)\\} $currentLine {\\\\} currentLine 171 set re [lindex $currentLine 0] 172 set flags [lindex $currentLine 1] 173 set str [lindex $currentLine 2] 174 175 # based on flags, decide whether to skip the test 176 177 if {[findSkipFlag $flags]} { 178 regsub -all {\[|\]|\(|\)|\{|\}|\#} $currentLine {\&} line 179 set msg "\# skipping char mapping test from line $srcLineNum\n" 180 append msg "print \{... skip test from line $srcLineNum: $line\}" 181 return $msg 182 } 183 184 # perform mapping if '=' flag exists 185 186 set noBraces 0 187 if {[regexp {=|>} $flags] == 1} { 188 regsub -all {_} $currentLine {\\ } currentLine 189 regsub -all {A} $currentLine {\\007} currentLine 190 regsub -all {B} $currentLine {\\b} currentLine 191 regsub -all {E} $currentLine {\\033} currentLine 192 regsub -all {F} $currentLine {\\f} currentLine 193 regsub -all {N} $currentLine {\\n} currentLine 194 195 # if and \r substitutions are made, do not wrap re, flags, 196 # str, and result in braces 197 198 set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine] 199 regsub -all {T} $currentLine {\\t} currentLine 200 regsub -all {V} $currentLine {\\v} currentLine 201 if {[regexp {=} $flags] == 1} { 202 set re [lindex $currentLine 0] 203 } 204 set str [lindex $currentLine 2] 205 } 206 set flags [removeFlags $flags] 207 208 # find the test result 209 210 set numVars [expr $len - 3] 211 set vars {} 212 set vals {} 213 set result 0 214 set v 0 215 216 if {[regsub {\*} "$flags" "" newFlags] == 1} { 217 # an error is expected 218 219 if {[string compare $str "EMPTY"] == 0} { 220 # empty regexp is not an error 221 # skip this test 222 223 return "\# skipping the empty-re test from line $srcLineNum\n" 224 } 225 set flags $newFlags 226 set result "\{1 \{[convertErrCode $str]\}\}" 227 } elseif {$numVars > 0} { 228 # at least 1 match is made 229 230 if {[regexp {s} $flags] == 1} { 231 set result "\{0 1\}" 232 } else { 233 while {$v < $numVars} { 234 append vars " var($v)" 235 append vals " \$var($v)" 236 incr v 237 } 238 set tmp [removeAts [lrange $currentLine 3 $len]] 239 set result "\{0 \{1 $tmp\}\}" 240 if {$noBraces} { 241 set result "\[subst $result\]" 242 } 243 } 244 } else { 245 # no match is made 246 247 set result "\{0 0\}" 248 } 249 250 # set up the test and write it to the output file 251 252 set cmd [prepareCmd $flags $re $str $vars $noBraces] 253 if {$cmd == -1} { 254 return "\# skipping test with metasyntax from line $srcLineNum\n" 255 } 256 257 set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n" 258 append test "\tcatch {unset var}\n" 259 append test "\tlist \[catch \{ \n" 260 append test "\t\tset match \[$cmd\] \n" 261 append test "\t\tlist \$match $vals \n" 262 append test "\t\} msg\] \$msg \n" 263 append test "\} $result \n" 264 return $test 265} 266 267