os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tools/regexpTestLib.tcl
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tools/regexpTestLib.tcl Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,266 @@
1.4 +# regexpTestLib.tcl --
1.5 +#
1.6 +# This file contains tcl procedures used by spencer2testregexp.tcl and
1.7 +# spencer2regexp.tcl, which are programs written to convert Henry
1.8 +# Spencer's test suite to tcl test files.
1.9 +#
1.10 +# Copyright (c) 1996 by Sun Microsystems, Inc.
1.11 +#
1.12 +# SCCS: @(#) regexpTestLib.tcl 1.4 98/01/22 14:48:34
1.13 +#
1.14 +
1.15 +proc readInputFile {} {
1.16 + global inFileName
1.17 + global lineArray
1.18 +
1.19 + set fileId [open $inFileName r]
1.20 +
1.21 + set i 0
1.22 + while {[gets $fileId line] >= 0} {
1.23 +
1.24 + set len [string length $line]
1.25 +
1.26 + if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} {
1.27 + if {[info exists lineArray(c$i)] == 0} {
1.28 + set lineArray(c$i) 1
1.29 + } else {
1.30 + incr lineArray(c$i)
1.31 + }
1.32 + set line [string range $line 0 [expr $len - 2]]
1.33 + append lineArray($i) $line
1.34 + continue
1.35 + }
1.36 + if {[info exists lineArray(c$i)] == 0} {
1.37 + set lineArray(c$i) 1
1.38 + } else {
1.39 + incr lineArray(c$i)
1.40 + }
1.41 + append lineArray($i) $line
1.42 + incr i
1.43 + }
1.44 +
1.45 + close $fileId
1.46 + return $i
1.47 +}
1.48 +
1.49 +#
1.50 +# strings with embedded @'s are truncated
1.51 +# unpreceeded @'s are replaced by {}
1.52 +#
1.53 +proc removeAts {ls} {
1.54 + set len [llength $ls]
1.55 + set newLs {}
1.56 + foreach item $ls {
1.57 + regsub @.* $item "" newItem
1.58 + lappend newLs $newItem
1.59 + }
1.60 + return $newLs
1.61 +}
1.62 +
1.63 +proc convertErrCode {code} {
1.64 +
1.65 + set errMsg "couldn't compile regular expression pattern:"
1.66 +
1.67 + if {[string compare $code "INVARG"] == 0} {
1.68 + return "$errMsg invalid argument to regex routine"
1.69 + } elseif {[string compare $code "BADRPT"] == 0} {
1.70 + return "$errMsg ?+* follows nothing"
1.71 + } elseif {[string compare $code "BADBR"] == 0} {
1.72 + return "$errMsg invalid repetition count(s)"
1.73 + } elseif {[string compare $code "BADOPT"] == 0} {
1.74 + return "$errMsg invalid embedded option"
1.75 + } elseif {[string compare $code "EPAREN"] == 0} {
1.76 + return "$errMsg unmatched ()"
1.77 + } elseif {[string compare $code "EBRACE"] == 0} {
1.78 + return "$errMsg unmatched {}"
1.79 + } elseif {[string compare $code "EBRACK"] == 0} {
1.80 + return "$errMsg unmatched \[\]"
1.81 + } elseif {[string compare $code "ERANGE"] == 0} {
1.82 + return "$errMsg invalid character range"
1.83 + } elseif {[string compare $code "ECTYPE"] == 0} {
1.84 + return "$errMsg invalid character class"
1.85 + } elseif {[string compare $code "ECOLLATE"] == 0} {
1.86 + return "$errMsg invalid collating element"
1.87 + } elseif {[string compare $code "EESCAPE"] == 0} {
1.88 + return "$errMsg invalid escape sequence"
1.89 + } elseif {[string compare $code "BADPAT"] == 0} {
1.90 + return "$errMsg invalid regular expression"
1.91 + } elseif {[string compare $code "ESUBREG"] == 0} {
1.92 + return "$errMsg invalid backreference number"
1.93 + } elseif {[string compare $code "IMPOSS"] == 0} {
1.94 + return "$errMsg can never match"
1.95 + }
1.96 + return "$errMsg $code"
1.97 +}
1.98 +
1.99 +proc writeOutputFile {numLines fcn} {
1.100 + global outFileName
1.101 + global lineArray
1.102 +
1.103 + # open output file and write file header info to it.
1.104 +
1.105 + set fileId [open $outFileName w]
1.106 +
1.107 + puts $fileId "# Commands covered: $fcn"
1.108 + puts $fileId "#"
1.109 + puts $fileId "# This Tcl-generated file contains tests for the $fcn tcl command."
1.110 + puts $fileId "# Sourcing this file into Tcl runs the tests and generates output for"
1.111 + puts $fileId "# errors. No output means no errors were found. Setting VERBOSE to"
1.112 + puts $fileId "# -1 will run tests that are known to fail."
1.113 + puts $fileId "#"
1.114 + puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc."
1.115 + puts $fileId "#"
1.116 + puts $fileId "# See the file \"license.terms\" for information on usage and redistribution"
1.117 + puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES."
1.118 + puts $fileId "#"
1.119 + puts $fileId "\# SCCS: \%Z\% \%M\% \%I\% \%E\% \%U\%"
1.120 + puts $fileId "\nproc print \{arg\} \{puts \$arg\}\n"
1.121 + puts $fileId "if \{\[string compare test \[info procs test\]\] == 1\} \{"
1.122 + puts $fileId " source defs ; set VERBOSE -1\n\}\n"
1.123 + puts $fileId "if \{\$VERBOSE != -1\} \{"
1.124 + puts $fileId " proc print \{arg\} \{\}\n\}\n"
1.125 + puts $fileId "#"
1.126 + puts $fileId "# The remainder of this file is Tcl tests that have been"
1.127 + puts $fileId "# converted from Henry Spencer's regexp test suite."
1.128 + puts $fileId "#\n"
1.129 +
1.130 + set lineNum 0
1.131 + set srcLineNum 1
1.132 + while {$lineNum < $numLines} {
1.133 +
1.134 + set currentLine $lineArray($lineNum)
1.135 +
1.136 + # copy comment string to output file and continue
1.137 +
1.138 + if {[string index $currentLine 0] == "#"} {
1.139 + puts $fileId $currentLine
1.140 + incr srcLineNum $lineArray(c$lineNum)
1.141 + incr lineNum
1.142 + continue
1.143 + }
1.144 +
1.145 + set len [llength $currentLine]
1.146 +
1.147 + # copy empty string to output file and continue
1.148 +
1.149 + if {$len == 0} {
1.150 + puts $fileId "\n"
1.151 + incr srcLineNum $lineArray(c$lineNum)
1.152 + incr lineNum
1.153 + continue
1.154 + }
1.155 + if {($len < 3)} {
1.156 + puts "warning: test is too short --\n\t$currentLine"
1.157 + incr srcLineNum $lineArray(c$lineNum)
1.158 + incr lineNum
1.159 + continue
1.160 + }
1.161 +
1.162 + puts $fileId [convertTestLine $currentLine $len $lineNum $srcLineNum]
1.163 +
1.164 + incr srcLineNum $lineArray(c$lineNum)
1.165 + incr lineNum
1.166 + }
1.167 +
1.168 + close $fileId
1.169 +}
1.170 +
1.171 +proc convertTestLine {currentLine len lineNum srcLineNum} {
1.172 +
1.173 + regsub -all {(?b)\\} $currentLine {\\\\} currentLine
1.174 + set re [lindex $currentLine 0]
1.175 + set flags [lindex $currentLine 1]
1.176 + set str [lindex $currentLine 2]
1.177 +
1.178 + # based on flags, decide whether to skip the test
1.179 +
1.180 + if {[findSkipFlag $flags]} {
1.181 + regsub -all {\[|\]|\(|\)|\{|\}|\#} $currentLine {\&} line
1.182 + set msg "\# skipping char mapping test from line $srcLineNum\n"
1.183 + append msg "print \{... skip test from line $srcLineNum: $line\}"
1.184 + return $msg
1.185 + }
1.186 +
1.187 + # perform mapping if '=' flag exists
1.188 +
1.189 + set noBraces 0
1.190 + if {[regexp {=|>} $flags] == 1} {
1.191 + regsub -all {_} $currentLine {\\ } currentLine
1.192 + regsub -all {A} $currentLine {\\007} currentLine
1.193 + regsub -all {B} $currentLine {\\b} currentLine
1.194 + regsub -all {E} $currentLine {\\033} currentLine
1.195 + regsub -all {F} $currentLine {\\f} currentLine
1.196 + regsub -all {N} $currentLine {\\n} currentLine
1.197 +
1.198 + # if and \r substitutions are made, do not wrap re, flags,
1.199 + # str, and result in braces
1.200 +
1.201 + set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine]
1.202 + regsub -all {T} $currentLine {\\t} currentLine
1.203 + regsub -all {V} $currentLine {\\v} currentLine
1.204 + if {[regexp {=} $flags] == 1} {
1.205 + set re [lindex $currentLine 0]
1.206 + }
1.207 + set str [lindex $currentLine 2]
1.208 + }
1.209 + set flags [removeFlags $flags]
1.210 +
1.211 + # find the test result
1.212 +
1.213 + set numVars [expr $len - 3]
1.214 + set vars {}
1.215 + set vals {}
1.216 + set result 0
1.217 + set v 0
1.218 +
1.219 + if {[regsub {\*} "$flags" "" newFlags] == 1} {
1.220 + # an error is expected
1.221 +
1.222 + if {[string compare $str "EMPTY"] == 0} {
1.223 + # empty regexp is not an error
1.224 + # skip this test
1.225 +
1.226 + return "\# skipping the empty-re test from line $srcLineNum\n"
1.227 + }
1.228 + set flags $newFlags
1.229 + set result "\{1 \{[convertErrCode $str]\}\}"
1.230 + } elseif {$numVars > 0} {
1.231 + # at least 1 match is made
1.232 +
1.233 + if {[regexp {s} $flags] == 1} {
1.234 + set result "\{0 1\}"
1.235 + } else {
1.236 + while {$v < $numVars} {
1.237 + append vars " var($v)"
1.238 + append vals " \$var($v)"
1.239 + incr v
1.240 + }
1.241 + set tmp [removeAts [lrange $currentLine 3 $len]]
1.242 + set result "\{0 \{1 $tmp\}\}"
1.243 + if {$noBraces} {
1.244 + set result "\[subst $result\]"
1.245 + }
1.246 + }
1.247 + } else {
1.248 + # no match is made
1.249 +
1.250 + set result "\{0 0\}"
1.251 + }
1.252 +
1.253 + # set up the test and write it to the output file
1.254 +
1.255 + set cmd [prepareCmd $flags $re $str $vars $noBraces]
1.256 + if {$cmd == -1} {
1.257 + return "\# skipping test with metasyntax from line $srcLineNum\n"
1.258 + }
1.259 +
1.260 + set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n"
1.261 + append test "\tcatch {unset var}\n"
1.262 + append test "\tlist \[catch \{ \n"
1.263 + append test "\t\tset match \[$cmd\] \n"
1.264 + append test "\t\tlist \$match $vals \n"
1.265 + append test "\t\} msg\] \$msg \n"
1.266 + append test "\} $result \n"
1.267 + return $test
1.268 +}
1.269 +