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