path: root/tools/regexpTestLib.tcl

# regexpTestLib.tcl --
#
# This file contains tcl procedures used by spencer2testregexp.tcl and
# spencer2regexp.tcl, which are programs written to convert Henry
# Spencer's test suite to tcl test files.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.

proc readInputFile {} {
    global inFileName
    global lineArray

    set fileId [open $inFileName r]

    set i 0
    while {[gets $fileId line] >= 0} {

	set len [string length $line]

	if {($len > 0) && ([string index $line [expr {$len - 1}]] eq "\\")} {
	    if {![info exists lineArray(c$i)]} {
		set lineArray(c$i) 1
	    } else {
		incr lineArray(c$i)
	    }
	  set line [string range $line 0 [expr {$len - 2}]]
	    append lineArray($i) $line
	    continue
	}
	if {![info exists lineArray(c$i)]} {
	    set lineArray(c$i) 1
	} else {
	    incr lineArray(c$i)
	}
	append lineArray($i) $line
	incr i
    }

    close $fileId
    return $i
}

#
# strings with embedded @'s are truncated
# unpreceeded @'s are replaced by {}
#
proc removeAts {ls} {
    set len [llength $ls]
    set newLs [list]
    foreach item $ls {
	regsub @.* $item "" newItem
	lappend newLs $newItem
    }
    return $newLs
}

proc convertErrCode {code} {
  array set msgCode {
    BADBR	"invalid repetition count(s)"
    BADOPT	"invalid embedded option"
    BADPAT	"invalid regular expression"
    BADRPT	"?+* follows nothing"
    EBRACE	"unmatched {}"
    EBRACK	"unmatched \[\]"
    ECOLLATE	"invalid collating element"
    ECTYPE	"invalid character class"
    EESCAPE	"invalid escape sequence"
    EPAREN	"unmatched ()"
    ERANGE	"invalid character range"
    ESUBREG	"invalid backreference number"
    IMPOSS	"can never match"
    INVARG	"invalid argument to regex routine"
  }

  set errMsg "couldn't compile regular expression pattern:"

  if {[info exists msgCode($code)]} {
    return "$errMsg $msgCode($code)"
  } else {
    return "$errMsg $code"
  }
}

proc writeOutputFile {numLines fcn} {
    global outFileName
    global lineArray

    # open output file and write file header info to it.

    set fileId [open $outFileName w]

    puts $fileId "# Commands covered:  $fcn"
    puts $fileId "#"
    puts $fileId "# This Tcl-generated file contains tests for the $fcn tcl command."
    puts $fileId "# Sourcing this file into Tcl runs the tests and generates output for"
    puts $fileId "# errors.  No output means no errors were found.  Setting VERBOSE to"
    puts $fileId "# -1 will run tests that are known to fail."
    puts $fileId "#"
    puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc."
    puts $fileId "#"
    puts $fileId "# See the file \"license.terms\" for information on usage and redistribution"
    puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES."
    puts $fileId "#"
    puts $fileId "\# SCCS: \%Z\% \%M\% \%I\% \%E\% \%U\%"
    puts $fileId "\nproc print \{arg\} \{puts \$arg\}\n"
    puts $fileId "if \{\[string compare test \[info procs test\]\] == 1\} \{"
    puts $fileId "    source defs ; set VERBOSE -1\n\}\n"
    puts $fileId "if \{\$VERBOSE != -1\} \{"
    puts $fileId "    proc print \{arg\} \{\}\n\}\n"
    puts $fileId "#"
    puts $fileId "# The remainder of this file is Tcl tests that have been"
    puts $fileId "# converted from Henry Spencer's regexp test suite."
    puts $fileId "#\n"

    set lineNum 0
    set srcLineNum 1
    while {$lineNum < $numLines} {

	set currentLine $lineArray($lineNum)

	# copy comment string to output file and continue

	if {[string index $currentLine 0] == "#"} {
	    puts $fileId $currentLine
	    incr srcLineNum $lineArray(c$lineNum)
	    incr lineNum
	    continue
	}

	set len [llength $currentLine]

	# copy empty string to output file and continue

	if {$len == 0} {
	    puts $fileId "\n"
	    incr srcLineNum $lineArray(c$lineNum)
	    incr lineNum
	    continue
	}
	if {($len < 3)} {
	    puts "warning: test is too short --\n\t$currentLine"
	    incr srcLineNum $lineArray(c$lineNum)
	    incr lineNum
	    continue
	}

	puts $fileId [convertTestLine $currentLine $len $lineNum $srcLineNum]

	incr srcLineNum $lineArray(c$lineNum)
	incr lineNum
    }

    close $fileId
}

proc convertTestLine {currentLine len lineNum srcLineNum} {

    regsub -all {(?b)\\} $currentLine {\\\\} currentLine
    lassign $currentLine re flags str

    # 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

    set noBraces 0
    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

	# if and \r substitutions are made, do not wrap re, flags,
	# str, and result in braces

	set noBraces [regsub -all "R" $currentLine {\\\u000D} 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 {$str eq "EMPTY"} {
	    # 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 tmp [removeAts [lrange $currentLine 3 $len]]
	    set result "\{0 \{1 $tmp\}\}"
	    if {$noBraces} {
		set result "\[subst $result\]"
	    }
	}
    } else {
	# no match is made

	set result "\{0 0\}"
    }

    # set up the test and write it to the output file

    set cmd [prepareCmd $flags $re $str $vars $noBraces]
    if {$cmd == -1} {
	return "\# skipping test with metasyntax from line $srcLineNum\n"
    }

    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
}