sl@0: # regexpTestLib.tcl --
sl@0: #
sl@0: # This file contains tcl procedures used by spencer2testregexp.tcl and
sl@0: # spencer2regexp.tcl, which are programs written to convert Henry
sl@0: # Spencer's test suite to tcl test files.
sl@0: #
sl@0: # Copyright (c) 1996 by Sun Microsystems, Inc.
sl@0: #
sl@0: # SCCS: @(#) regexpTestLib.tcl 1.4 98/01/22 14:48:34
sl@0: # 
sl@0: 
sl@0: proc readInputFile {} {
sl@0:     global inFileName
sl@0:     global lineArray
sl@0: 
sl@0:     set fileId [open $inFileName r]
sl@0: 
sl@0:     set i 0
sl@0:     while {[gets $fileId line] >= 0} {
sl@0: 
sl@0: 	set len [string length $line]
sl@0: 
sl@0: 	if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} {
sl@0: 	    if {[info exists lineArray(c$i)] == 0} {
sl@0: 		set lineArray(c$i) 1
sl@0: 	    } else {
sl@0: 		incr lineArray(c$i)
sl@0: 	    }
sl@0: 	    set line [string range $line 0 [expr $len - 2]]
sl@0: 	    append lineArray($i) $line
sl@0: 	    continue
sl@0: 	}
sl@0: 	if {[info exists lineArray(c$i)] == 0} {
sl@0: 	    set lineArray(c$i) 1
sl@0: 	} else {
sl@0: 	    incr lineArray(c$i)
sl@0: 	}
sl@0: 	append lineArray($i) $line
sl@0: 	incr i
sl@0:     }
sl@0: 
sl@0:     close $fileId
sl@0:     return $i
sl@0: }
sl@0: 
sl@0: #
sl@0: # strings with embedded @'s are truncated
sl@0: # unpreceeded @'s are replaced by {}
sl@0: # 
sl@0: proc removeAts {ls} {
sl@0:     set len [llength $ls]
sl@0:     set newLs {}
sl@0:     foreach item $ls {
sl@0: 	regsub @.* $item "" newItem
sl@0: 	lappend newLs $newItem
sl@0:     }
sl@0:     return $newLs
sl@0: }
sl@0: 
sl@0: proc convertErrCode {code} {
sl@0: 
sl@0:     set errMsg "couldn't compile regular expression pattern:"
sl@0: 
sl@0:     if {[string compare $code "INVARG"] == 0} {
sl@0: 	return "$errMsg invalid argument to regex routine"
sl@0:     } elseif {[string compare $code "BADRPT"] == 0} {
sl@0: 	return "$errMsg ?+* follows nothing"
sl@0:     } elseif {[string compare $code "BADBR"] == 0} {
sl@0: 	return "$errMsg invalid repetition count(s)"
sl@0:     } elseif {[string compare $code "BADOPT"] == 0} {
sl@0: 	return "$errMsg invalid embedded option"
sl@0:     } elseif {[string compare $code "EPAREN"] == 0} {
sl@0: 	return "$errMsg unmatched ()"
sl@0:     } elseif {[string compare $code "EBRACE"] == 0} {
sl@0: 	return "$errMsg unmatched {}"
sl@0:     } elseif {[string compare $code "EBRACK"] == 0} {
sl@0: 	return "$errMsg unmatched \[\]"
sl@0:     } elseif {[string compare $code "ERANGE"] == 0} {
sl@0: 	return "$errMsg invalid character range"
sl@0:     } elseif {[string compare $code "ECTYPE"] == 0} {
sl@0: 	return "$errMsg invalid character class"
sl@0:     } elseif {[string compare $code "ECOLLATE"] == 0} {
sl@0: 	return "$errMsg invalid collating element"
sl@0:     } elseif {[string compare $code "EESCAPE"] == 0} {
sl@0: 	return "$errMsg invalid escape sequence"
sl@0:     } elseif {[string compare $code "BADPAT"] == 0} {
sl@0: 	return "$errMsg invalid regular expression"
sl@0:     } elseif {[string compare $code "ESUBREG"] == 0} {
sl@0: 	return "$errMsg invalid backreference number"
sl@0:     } elseif {[string compare $code "IMPOSS"] == 0} {
sl@0: 	return "$errMsg can never match"
sl@0:     }
sl@0:     return "$errMsg $code"
sl@0: }
sl@0: 
sl@0: proc writeOutputFile {numLines fcn} {
sl@0:     global outFileName
sl@0:     global lineArray
sl@0: 
sl@0:     # open output file and write file header info to it. 
sl@0: 
sl@0:     set fileId [open $outFileName w]
sl@0: 
sl@0:     puts $fileId "# Commands covered:  $fcn"
sl@0:     puts $fileId "#"
sl@0:     puts $fileId "# This Tcl-generated file contains tests for the $fcn tcl command."
sl@0:     puts $fileId "# Sourcing this file into Tcl runs the tests and generates output for"
sl@0:     puts $fileId "# errors.  No output means no errors were found.  Setting VERBOSE to"
sl@0:     puts $fileId "# -1 will run tests that are known to fail."
sl@0:     puts $fileId "#"
sl@0:     puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc."
sl@0:     puts $fileId "#"
sl@0:     puts $fileId "# See the file \"license.terms\" for information on usage and redistribution"
sl@0:     puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES."
sl@0:     puts $fileId "#"
sl@0:     puts $fileId "\# SCCS: \%Z\% \%M\% \%I\% \%E\% \%U\%"
sl@0:     puts $fileId "\nproc print \{arg\} \{puts \$arg\}\n"
sl@0:     puts $fileId "if \{\[string compare test \[info procs test\]\] == 1\} \{"
sl@0:     puts $fileId "    source defs ; set VERBOSE -1\n\}\n"
sl@0:     puts $fileId "if \{\$VERBOSE != -1\} \{"
sl@0:     puts $fileId "    proc print \{arg\} \{\}\n\}\n"
sl@0:     puts $fileId "#"
sl@0:     puts $fileId "# The remainder of this file is Tcl tests that have been"
sl@0:     puts $fileId "# converted from Henry Spencer's regexp test suite."
sl@0:     puts $fileId "#\n"
sl@0: 
sl@0:     set lineNum 0
sl@0:     set srcLineNum 1
sl@0:     while {$lineNum < $numLines} {
sl@0: 
sl@0: 	set currentLine $lineArray($lineNum)
sl@0: 
sl@0: 	# copy comment string to output file and continue
sl@0: 
sl@0: 	if {[string index $currentLine 0] == "#"} {
sl@0: 	    puts $fileId $currentLine
sl@0: 	    incr srcLineNum $lineArray(c$lineNum)
sl@0: 	    incr lineNum
sl@0: 	    continue	    
sl@0: 	}
sl@0: 
sl@0: 	set len [llength $currentLine]
sl@0: 
sl@0: 	# copy empty string to output file and continue
sl@0: 
sl@0: 	if {$len == 0} {
sl@0: 	    puts $fileId "\n"
sl@0: 	    incr srcLineNum $lineArray(c$lineNum)
sl@0: 	    incr lineNum
sl@0: 	    continue	    
sl@0: 	}
sl@0: 	if {($len < 3)} {
sl@0: 	    puts "warning: test is too short --\n\t$currentLine"
sl@0: 	    incr srcLineNum $lineArray(c$lineNum)
sl@0: 	    incr lineNum
sl@0: 	    continue
sl@0: 	}
sl@0: 
sl@0: 	puts $fileId [convertTestLine $currentLine $len $lineNum $srcLineNum]
sl@0: 
sl@0: 	incr srcLineNum $lineArray(c$lineNum)
sl@0: 	incr lineNum
sl@0:     }
sl@0: 
sl@0:     close $fileId
sl@0: }
sl@0: 
sl@0: proc convertTestLine {currentLine len lineNum srcLineNum} {
sl@0: 
sl@0:     regsub -all {(?b)\\} $currentLine {\\\\} currentLine
sl@0:     set re [lindex $currentLine 0]
sl@0:     set flags [lindex $currentLine 1]
sl@0:     set str [lindex $currentLine 2]
sl@0: 
sl@0:     # based on flags, decide whether to skip the test
sl@0: 
sl@0:     if {[findSkipFlag $flags]} {
sl@0: 	regsub -all {\[|\]|\(|\)|\{|\}|\#} $currentLine {\&} line
sl@0: 	set msg "\# skipping char mapping test from line $srcLineNum\n"
sl@0: 	append msg "print \{... skip test from line $srcLineNum:  $line\}"
sl@0: 	return $msg
sl@0:     }
sl@0: 
sl@0:     # perform mapping if '=' flag exists
sl@0: 
sl@0:     set noBraces 0
sl@0:     if {[regexp {=|>} $flags] == 1} {
sl@0: 	regsub -all {_} $currentLine {\\ } currentLine
sl@0: 	regsub -all {A} $currentLine {\\007} currentLine
sl@0: 	regsub -all {B} $currentLine {\\b} currentLine
sl@0: 	regsub -all {E} $currentLine {\\033} currentLine
sl@0: 	regsub -all {F} $currentLine {\\f} currentLine
sl@0: 	regsub -all {N} $currentLine {\\n} currentLine
sl@0: 
sl@0: 	# if and \r substitutions are made, do not wrap re, flags,
sl@0: 	# str, and result in braces
sl@0: 
sl@0: 	set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine]
sl@0: 	regsub -all {T} $currentLine {\\t} currentLine
sl@0: 	regsub -all {V} $currentLine {\\v} currentLine
sl@0: 	if {[regexp {=} $flags] == 1} {
sl@0: 	    set re [lindex $currentLine 0]
sl@0: 	}
sl@0: 	set str [lindex $currentLine 2]
sl@0:     }
sl@0:     set flags [removeFlags $flags]
sl@0: 
sl@0:     # find the test result
sl@0: 
sl@0:     set numVars [expr $len - 3]
sl@0:     set vars {}
sl@0:     set vals {}
sl@0:     set result 0
sl@0:     set v 0
sl@0:     
sl@0:     if {[regsub {\*} "$flags" "" newFlags] == 1} {
sl@0: 	# an error is expected
sl@0: 	
sl@0: 	if {[string compare $str "EMPTY"] == 0} {
sl@0: 	    # empty regexp is not an error
sl@0: 	    # skip this test
sl@0: 	    
sl@0: 	    return "\# skipping the empty-re test from line $srcLineNum\n"
sl@0: 	}
sl@0: 	set flags $newFlags
sl@0: 	set result "\{1 \{[convertErrCode $str]\}\}"
sl@0:     } elseif {$numVars > 0} {
sl@0: 	# at least 1 match is made
sl@0: 	
sl@0: 	if {[regexp {s} $flags] == 1} {
sl@0: 	    set result "\{0 1\}"
sl@0: 	} else {
sl@0: 	    while {$v < $numVars} {
sl@0: 		append vars " var($v)"
sl@0: 		append vals " \$var($v)"
sl@0: 		incr v
sl@0: 	    }
sl@0: 	    set tmp [removeAts [lrange $currentLine 3 $len]]
sl@0: 	    set result "\{0 \{1 $tmp\}\}"
sl@0: 	    if {$noBraces} {
sl@0: 		set result "\[subst $result\]"
sl@0: 	    }
sl@0: 	}
sl@0:     } else {
sl@0: 	# no match is made
sl@0: 	
sl@0: 	set result "\{0 0\}"
sl@0:     }
sl@0: 
sl@0:     # set up the test and write it to the output file
sl@0: 
sl@0:     set cmd [prepareCmd $flags $re $str $vars $noBraces]
sl@0:     if {$cmd == -1} {
sl@0: 	return "\# skipping test with metasyntax from line $srcLineNum\n"	    
sl@0:     }
sl@0: 
sl@0:     set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n"
sl@0:     append test "\tcatch {unset var}\n"
sl@0:     append test "\tlist \[catch \{ \n"
sl@0:     append test "\t\tset match \[$cmd\] \n"
sl@0:     append test "\t\tlist \$match $vals \n"
sl@0:     append test "\t\} msg\] \$msg \n"
sl@0:     append test "\} $result \n"
sl@0:     return $test
sl@0: }
sl@0: