开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
regexpTestLib.tcl
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：8k
源码类别：

通讯编程

开发平台：

Visual C++

regexpTestLib.tcl：源码内容
  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 -1n}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 --nt$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 $srcLineNumn"
  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
  215.     
  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
  222.     
  223.     return "# skipping the empty-re test from line $srcLineNumn"
  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 $srcLineNumn"     
  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 "ttset match [$cmd] n"
  261.     append test "ttlist $match $vals n"
  262.     append test "t} msg] $msg n"
  263.     append test "} $result n"
  264.     return $test
  265. }