Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tools/regexpTestLib.tcl@260cb5ec6c19

     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 #

    12 proc readInputFile {} {

    13     global inFileName

    14     global lineArray

    16     set fileId [open $inFileName r]

    18     set i 0

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

    21 	set len [string length $line]

    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     }

    42     close $fileId

    43     return $i

    44 }

    46 #

    47 # strings with embedded @'s are truncated

    48 # unpreceeded @'s are replaced by {}

    49 #

    50 proc 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 }

    60 proc convertErrCode {code} {

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

    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 }

    96 proc writeOutputFile {numLines fcn} {

    97     global outFileName

    98     global lineArray

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

   102     set fileId [open $outFileName w]

   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"

   127     set lineNum 0

   128     set srcLineNum 1

   129     while {$lineNum < $numLines} {

   131 	set currentLine $lineArray($lineNum)

   133 	# copy comment string to output file and continue

   135 	if {[string index $currentLine 0] == "#"} {

   136 	    puts $fileId $currentLine

   137 	    incr srcLineNum $lineArray(c$lineNum)

   138 	    incr lineNum

   139 	    continue

   140 	}

   142 	set len [llength $currentLine]

   144 	# copy empty string to output file and continue

   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 	}

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

   161 	incr srcLineNum $lineArray(c$lineNum)

   162 	incr lineNum

   163     }

   165     close $fileId

   166 }

   168 proc convertTestLine {currentLine len lineNum srcLineNum} {

   170     regsub -all {(?b)\\} $currentLine {\\\\} currentLine

   171     set re [lindex $currentLine 0]

   172     set flags [lindex $currentLine 1]

   173     set str [lindex $currentLine 2]

   175     # based on flags, decide whether to skip the test

   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     }

   184     # perform mapping if '=' flag exists

   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

   195 	# if and \r substitutions are made, do not wrap re, flags,

   196 	# str, and result in braces

   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]

   208     # find the test result

   210     set numVars [expr $len - 3]

   211     set vars {}

   212     set vals {}

   213     set result 0

   214     set v 0

   216     if {[regsub {\*} "$flags" "" newFlags] == 1} {

   217 	# an error is expected

   219 	if {[string compare $str "EMPTY"] == 0} {

   220 	    # empty regexp is not an error

   221 	    # skip this test

   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

   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

   247 	set result "\{0 0\}"

   248     }

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

   252     set cmd [prepareCmd $flags $re $str $vars $noBraces]

   253     if {$cmd == -1} {

   254 	return "\# skipping test with metasyntax from line $srcLineNum\n"

   255     }

   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 }

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--