reg.test

来自「tcl是工具命令语言」· TEST 代码 · 共 1,001 行 · 第 1/2 页

# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer.  All rights reserved.
#
# RCS: @(#) $Id: reg.test,v 1.16 2002/07/29 12:28:35 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# All tests require the testregexp command, return if this
# command doesn't exist

::tcltest::testConstraint testregexp \
	[expr {[info commands testregexp] != {}}]
::tcltest::testConstraint localeRegexp 0

# This file uses some custom procedures, defined below, for regexp regression
# testing.  The name of the procedure indicates the general nature of the
# test:
#	e	compile error expected
#	f	match failure expected
#	m	successful match
#	i	successful match with -indices (used in checking things like
#		nonparticipating subexpressions)
#	p	unsuccessful match with -indices (!!) (used in checking
#		partial-match reporting)
# There is also "doing" which sets up title and major test number for each
# block of tests.

# The first 3 arguments are constant:  a minor number (which often gets
# a letter or two suffixed to it internally), some flags, and the RE itself.
# For e, the remaining argument is the name of the compile error expected,
# less the leading "REG_".  For the rest, the next argument is the string
# to try the match against.  Remaining arguments are the substring expected
# to be matched, and any substrings expected to be matched by subexpressions.
# (For f, these arguments are optional, and if present are ignored except
# that they indicate how many subexpressions should be present in the RE.)
# It is an error for the number of subexpression arguments to be wrong.
# Cases involving nonparticipating subexpressions, checking where empty
# substrings are located, etc. should be done using i and p.

# The flag characters are complex and a bit eclectic.  Generally speaking, 
# lowercase letters are compile options, uppercase are expected re_info
# bits, and nonalphabetics are match options, controls for how the test is 
# run, or testing options.  The one small surprise is that AREs are the
# default, and you must explicitly request lesser flavors of RE.  The flags
# are as follows.  It is admitted that some are not very mnemonic.
# There are some others which are purely debugging tools and are not
# useful in this file.
#
#	-	no-op (placeholder)
#	+	provide fake xy equivalence class and ch collating element
#	%	force small state-set cache in matcher (to test cache replace)
#	^	beginning of string is not beginning of line
#	$	end of string is not end of line
#	*	test is Unicode-specific, needs big character set
#
#	&	test as both ARE and BRE
#	b	BRE
#	e	ERE
#	a	turn advanced-features bit on (error unless ERE already)
#	q	literal string, no metacharacters at all
#
#	i	case-independent matching
#	o	("opaque") no subexpression capture
#	p	newlines are half-magic, excluded from . and [^ only
#	w	newlines are half-magic, significant to ^ and $ only
#	n	newlines are fully magic, both effects
#	x	expanded RE syntax
#	t	incomplete-match reporting
#
#	A	backslash-_a_lphanumeric seen
#	B	ERE/ARE literal-_b_race heuristic used
#	E	backslash (_e_scape) seen within []
#	H	looka_h_ead constraint seen
#	I	_i_mpossible to match
#	L	_l_ocale-specific construct seen
#	M	unportable (_m_achine-specific) construct seen
#	N	RE can match empty (_n_ull) string
#	P	non-_P_OSIX construct seen
#	Q	{} _q_uantifier seen
#	R	back _r_eference seen
#	S	POSIX-un_s_pecified syntax seen
#	T	prefers shortest (_t_iny)
#	U	saw original-POSIX botch:  unmatched right paren in ERE (_u_gh)

# The one area we can't easily test is memory-allocation failures (which
# are hard to provoke on command).  Embedded NULs also are not tested at
# the moment, but this is a historical accident which should be fixed.



# test procedures and related

set ask "about"
set xflags "xflags"
set testbypassed 0

# re_info abbreviation mapping table
set infonames(A) "REG_UBSALNUM"
set infonames(B) "REG_UBRACES"
set infonames(E) "REG_UBBS"
set infonames(H) "REG_ULOOKAHEAD"
set infonames(I) "REG_UIMPOSSIBLE"
set infonames(L) "REG_ULOCALE"
set infonames(M) "REG_UUNPORT"
set infonames(N) "REG_UEMPTYMATCH"
set infonames(P) "REG_UNONPOSIX"
set infonames(Q) "REG_UBOUNDS"
set infonames(R) "REG_UBACKREF"
set infonames(S) "REG_UUNSPEC"
set infonames(T) "REG_USHORTEST"
set infonames(U) "REG_UPBOTCH"
set infonameorder "RHQBAUEPSMLNIT"	;# must match bit order, lsb first

# set major test number and description
proc doing {major desc} {
	global prefix description testbypassed

	if {$testbypassed != 0} {
		puts stdout "!!! bypassed $testbypassed tests in\
					 $prefix, `$description'"
	}

	set prefix reg-$major
	set description "reg $desc"
	set testbypassed 0
}

# build test number (internal)
proc tno {testid} {
	return [lindex $testid 0]
}

# build description, with possible modifiers (internal)
proc desc {testid} {
	global description

	set d $description
	if {[llength $testid] > 1} {
		set d "([lreplace $testid 0 0]) $d"
	}
	return $d
}

# build trailing options and flags argument from a flags string (internal)
proc flags {fl} {
	global xflags

	set args [list]
	set flags ""
	foreach f [split $fl ""] {
		switch -exact -- $f {
		"i" { lappend args "-nocase" }
		"x" { lappend args "-expanded" }
		"n" { lappend args "-line" }
		"p" { lappend args "-linestop" }
		"w" { lappend args "-lineanchor" }
		"-" { }
		default { append flags $f }
		}
	}
	if {[string compare $flags ""] != 0} {
		lappend args -$xflags $flags
	}
	return $args
}

# build info-flags list from a flags string (internal)
proc infoflags {fl} {
	global infonames infonameorder

	set ret [list]
	foreach f [split $infonameorder ""] {
		if {[string first $f $fl] >= 0} {
			lappend ret $infonames($f)
		}
	}
	return $ret
}

# compilation error expected
proc e {testid flags re err} {
	global prefix ask errorCode

	# Tcl locale stuff doesn't do the ch/xy test fakery yet
	if {[string first "+" $flags] >= 0} {
	    # This will register as a skipped test
	    test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
	    return
	}

	# if &, test as both ARE and BRE
	set amp [string first "&" $flags]
	if {$amp >= 0} {
		set f [string range $flags 0 [expr $amp - 1]]
		append f [string range $flags [expr $amp + 1] end]
		e [linsert $testid end ARE] ${f} $re $err
		e [linsert $testid end BRE] ${f}b $re $err
		return
	}

	set cmd [concat [list testregexp -$ask] [flags $flags] [list $re]]
	set run "list \[catch \{$cmd\}\] \[lindex \$errorCode 1\]"
	test $prefix.[tno $testid] [desc $testid] \
		{testregexp} $run [list 1 REG_$err]
}

# match failure expected
proc f {testid flags re target args} {
	global prefix description ask

	# Tcl locale stuff doesn't do the ch/xy test fakery yet
	if {[string first "+" $flags] >= 0} {
	    # This will register as a skipped test
	    test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
	    return
	}

	# if &, test as both ARE and BRE
	set amp [string first "&" $flags]
	if {$amp >= 0} {
		set f [string range $flags 0 [expr $amp - 1]]
		append f [string range $flags [expr $amp + 1] end]
		eval [linsert $args 0 f [linsert $testid end ARE] ${f} $re \
								$target]
		eval [linsert $args 0 f [linsert $testid end BRE] ${f}b $re \
								$target]
		return
	}

	set f [flags $flags]
	set infoflags [infoflags $flags]
	set ccmd [concat [list testregexp -$ask] $f [list $re]]
	set nsub [expr [llength $args] - 1]
	if {$nsub == -1} {
		# didn't tell us number of subexps
		set ccmd "lreplace \[$ccmd\] 0 0"
		set info [list $infoflags]
	} else {
		set info [list $nsub $infoflags]
	}
	lappend testid "compile"
	test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info

	set testid [lreplace $testid end end "execute"]
	set ecmd [concat [list testregexp] $f [list $re $target]]
	test $prefix.[tno $testid] [desc $testid] {testregexp} $ecmd 0
}

# match expected, internal routine that does the work
# parameters like the "real" routines except they don't have "opts",
#  which is a possibly-empty list of switches for the regexp match attempt
# The ! flag is used to indicate expected match failure (for REG_EXPECT,
#  which wants argument testing even in the event of failure).
proc matchexpected {opts testid flags re target args} {
	global prefix description ask regBug

    if {[info exists regBug] && $regBug} {
	# This will register as a skipped test
	test $prefix.[tno $testid] [desc $testid] knownBug {format 0} {1}
	return
    }

	# Tcl locale stuff doesn't do the ch/xy test fakery yet
	if {[string first "+" $flags] >= 0} {
	    # This will register as a skipped test
	    test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
	    return
	}

	# if &, test as both BRE and ARE
	set amp [string first "&" $flags]
	if {$amp >= 0} {
		set f [string range $flags 0 [expr $amp - 1]]
		append f [string range $flags [expr $amp + 1] end]
		eval [concat [list matchexpected $opts \
			[linsert $testid end ARE] ${f} $re $target] $args]
		eval [concat [list matchexpected $opts \
			[linsert $testid end BRE] ${f}b $re $target] $args]
		return
	}

	set f [flags $flags]
	set infoflags [infoflags $flags]
	set ccmd [concat [list testregexp -$ask] $f [list $re]]
	set ecmd [concat [list testregexp] $opts $f [list $re $target]]

	set nsub [expr [llength $args] - 1]
	set names [list]
	set refs ""
	for {set i 0} {$i <= $nsub} {incr i} {
		if {$i == 0} {
			set name match
		} else {
			set name sub$i
		}
		lappend names $name
		append refs " \$$name"
		set $name ""
	}
	if {[string first "o" $flags] >= 0} {	;# REG_NOSUB kludge
		set nsub 0		;# unsigned value cannot be -1
	}
	if {[string first "t" $flags] >= 0} {	;# REG_EXPECT
		incr nsub -1		;# the extra does not count
	}
	set ecmd [concat $ecmd $names]
	set erun "list \[$ecmd\] $refs"
	set retcode [list 1]
	if {[string first "!" $flags] >= 0} {
		set retcode [list 0]
	}
	set result [concat $retcode $args]

	set info [list $nsub $infoflags]
	lappend testid "compile"
	test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info
	set testid [lreplace $testid end end "execute"]
	test $prefix.[tno $testid] [desc $testid] {testregexp} $erun $result
}

# match expected (no missing, empty, or ambiguous submatches)
# m testno flags re target mat submat ...
proc m {args} {
	eval matchexpected [linsert $args 0 [list]]
}

# match expected (full fanciness)
# i testno flags re target mat submat ...
proc i {args} {
	eval matchexpected [linsert $args 0 [list "-indices"]]
}

# partial match expected
# p testno flags re target mat "" ...
# Quirk:  number of ""s must be one more than number of subREs.
proc p {args} {
	set f [lindex $args 1]			;# add ! flag
	set args [lreplace $args 1 1 "!$f"]
	eval matchexpected [linsert $args 0 [list "-indices"]]
}

# test is a knownBug
proc knownBug {args} {
    set ::regBug 1
    uplevel #0 $args
    set ::regBug 0
}



# the tests themselves



# support functions and preliminary misc.
# This is sensitive to changes in message wording, but we really have to
# test the code->message expansion at least once.
test reg-0.1 "regexp error reporting" {
	list [catch {regexp (*) ign} msg] $msg
} {1 {couldn't compile regular expression pattern: quantifier operand invalid}}



doing 1 "basic sanity checks"
m  1	&	abc		abc	abc
f  2	&	abc		def
m  3	&	abc		xyabxabce	abc



doing 2 "invalid option combinations"
e  1	qe	a		INVARG
e  2	qa	a		INVARG
e  3	qx	a		INVARG
e  4	qn	a		INVARG
e  5	ba	a		INVARG



doing 3 "basic syntax"
i  1	&NS	""		a	{0 -1}
m  2	NS	a|		a	a
m  3	-	a|b		a	a
m  4	-	a|b		b	b
m  5	NS	a||b		b	b
m  6	&	ab		ab	ab



doing 4 "parentheses"
m  1	-	(a)e		ae	ae	a
m  2	o	(a)e		ae
m  3	b	{\(a\)b}	ab	ab	a
m  4	-	a((b)c)		abc	abc	bc	b
m  5	-	a(b)(c)		abc	abc	b	c
e  6	-	a(b		EPAREN
e  7	b	{a\(b}		EPAREN
# sigh, we blew it on the specs here... someday this will be fixed in POSIX,
#  but meanwhile, it's fixed in AREs
m  8	eU	a)b		a)b	a)b
e  9	-	a)b		EPAREN
e 10	b	{a\)b}		EPAREN
m 11	P	a(?:b)c		abc	abc
e 12	e	a(?:b)c		BADRPT
i 13	S	a()b		ab	{0 1}	{1 0}
m 14	SP	a(?:)b		ab	ab
i 15	S	a(|b)c		ac	{0 1}	{1 0}
m 16	S	a(b|)c		abc	abc	b



doing 5 "simple one-char matching"
# general case of brackets done later
m  1	&	a.b		axb	axb
f  2	&n	"a.b"		"a\nb"
m  3	&	{a[bc]d}	abd	abd
m  4	&	{a[bc]d}	acd	acd
f  5	&	{a[bc]d}	aed
f  6	&	{a[^bc]d}	abd
m  7	&	{a[^bc]d}	aed	aed
f  8	&p	"a\[^bc]d"	"a\nd"



doing 6 "context-dependent syntax"
# plus odds and ends
e  1	-	*		BADRPT
m  2	b	*		*	*
m  3	b	{\(*\)}		*	*	*
e  4	-	(*)		BADRPT
m  5	b	^*		*	*
e  6	-	^*		BADRPT
f  7	&	^b		^b
m  8	b	x^		x^	x^
f  9	I	x^		x
m 10	n	"\n^"		"x\nb"	"\n"
f 11	bS	{\(^b\)}	^b
m 12	-	(^b)		b	b	b
m 13	&	{x$}		x	x
m 14	bS	{\(x$\)}	x	x	x
m 15	-	{(x$)}		x	x	x
m 16	b	{x$y}		"x\$y"	"x\$y"
f 17	I	{x$y}		xy
m 18	n	"x\$\n"		"x\n"	"x\n"
e 19	-	+		BADRPT
e 20	-	?		BADRPT



doing 7 "simple quantifiers"
m  1	&N	a*		aa	aa
i  2	&N	a*		b	{0 -1}
m  3	-	a+		aa	aa
m  4	-	a?b		ab	ab
m  5	-	a?b		b	b
e  6	-	**		BADRPT
m  7	bN	**		***	***
e  8	&	a**		BADRPT
e  9	&	a**b		BADRPT
e 10	&	***		BADRPT
e 11	-	a++		BADRPT
e 12	-	a?+		BADRPT
e 13	-	a?*		BADRPT
e 14	-	a+*		BADRPT
e 15	-	a*+		BADRPT



doing 8 "braces"
m  1	NQ	"a{0,1}"	""	""
m  2	NQ	"a{0,1}"	ac	a
e  3	-	"a{1,0}"	BADBR
e  4	-	"a{1,2,3}"	BADBR
e  5	-	"a{257}"	BADBR
e  6	-	"a{1000}"	BADBR
e  7	-	"a{1"		EBRACE
e  8	-	"a{1n}"		BADBR
m  9	BS	"a{b"		"a\{b"	"a\{b"
m 10	BS	"a{"		"a\{"	"a\{"
m 11	bQ	"a\\{0,1\\}b"	cb	b
e 12	b	"a\\{0,1"	EBRACE
e 13	-	"a{0,1\\"	BADBR
m 14	Q	"a{0}b"		ab	b
m 15	Q	"a{0,0}b"	ab	b
m 16	Q	"a{0,1}b"	ab	ab
m 17	Q	"a{0,2}b"	b	b
m 18	Q	"a{0,2}b"	aab	aab
m 19	Q	"a{0,}b"	aab	aab
m 20	Q	"a{1,1}b"	aab	ab
m 21	Q	"a{1,3}b"	aaaab	aaab