pat.t

UNIX下perl实现代码

}

{
  local $lex_a = 2;
  my $lex_a = 43;
  my $lex_b = 17;
  my $lex_c = 27;
  my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
  print "not " unless $lex_res eq '1';
  print "ok $test\n";
  $test++;
  print "not " unless $lex_a eq '44';
  print "ok $test\n";
  $test++;
  print "not " unless $lex_c eq '43';
  print "ok $test\n";
  $test++;
}

{
  package aa;
  $c = 2;
  $::c = 3;
  '' =~ /(?{ $c = 4 })/;
  print "not " unless $c == 4;
}
print "ok $test\n";
$test++;
print "not " unless $c == 3;
print "ok $test\n";
$test++;  
  
sub must_warn_pat {
    my $warn_pat = shift;
    return sub { print "not " unless $_[0] =~ /$warn_pat/ }
}

sub must_warn {
    my ($warn_pat, $code) = @_;
    local %SIG;
    eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code;
    print "ok $test\n";
    $test++;
}


sub make_must_warn {
    my $warn_pat = shift;
    return sub { must_warn(must_warn_pat($warn_pat)) }
}

my $for_future = make_must_warn('reserved for future extensions');

&$for_future('q(a:[b]:) =~ /[x[:foo:]]/');

#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/');
print "ok $test\n"; $test++; # now a fatal croak

#&$for_future('q(a.[b].) =~ /[x[.foo.]]/');
print "ok $test\n"; $test++; # now a fatal croak

# test if failure of patterns returns empty list
$_ = 'aaa';
@_ = /bbb/;
print "not " if @_;
print "ok $test\n";
$test++;

@_ = /bbb/g;
print "not " if @_;
print "ok $test\n";
$test++;

@_ = /(bbb)/;
print "not " if @_;
print "ok $test\n";
$test++;

@_ = /(bbb)/g;
print "not " if @_;
print "ok $test\n";
$test++;

/a(?=.$)/;
print "not " if $#+ != 0 or $#- != 0;
print "ok $test\n";
$test++;

print "not " if $+[0] != 2 or $-[0] != 1;
print "ok $test\n";
$test++;

print "not " 
   if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2];
print "ok $test\n";
$test++;

/a(a)(a)/;
print "not " if $#+ != 2 or $#- != 2;
print "ok $test\n";
$test++;

print "not " if $+[0] != 3 or $-[0] != 0;
print "ok $test\n";
$test++;

print "not " if $+[1] != 2 or $-[1] != 1;
print "ok $test\n";
$test++;

print "not " if $+[2] != 3 or $-[2] != 2;
print "ok $test\n";
$test++;

print "not " 
   if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4];
print "ok $test\n";
$test++;

/.(a)(b)?(a)/;
print "not " if $#+ != 3 or $#- != 3;
print "ok $test\n";
$test++;

print "not " if $+[0] != 3 or $-[0] != 0;
print "ok $test\n";
$test++;

print "not " if $+[1] != 2 or $-[1] != 1;
print "ok $test\n";
$test++;

print "not " if $+[3] != 3 or $-[3] != 2;
print "ok $test\n";
$test++;

print "not " 
   if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4];
print "ok $test\n";
$test++;

/.(a)/;
print "not " if $#+ != 1 or $#- != 1;
print "ok $test\n";
$test++;

print "not " if $+[0] != 2 or $-[0] != 0;
print "ok $test\n";
$test++;

print "not " if $+[1] != 2 or $-[1] != 1;
print "ok $test\n";
$test++;

print "not " 
   if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3];
print "ok $test\n";
$test++;

eval { $+[0] = 13; };
print "not " 
   if $@ !~ /^Modification of a read-only value attempted/;
print "ok $test\n";
$test++;

eval { $-[0] = 13; };
print "not " 
   if $@ !~ /^Modification of a read-only value attempted/;
print "ok $test\n";
$test++;

eval { @+ = (7, 6, 5); };
print "not " 
   if $@ !~ /^Modification of a read-only value attempted/;
print "ok $test\n";
$test++;

eval { @- = qw(foo bar); };
print "not " 
   if $@ !~ /^Modification of a read-only value attempted/;
print "ok $test\n";
$test++;

/.(a)(ba*)?/;
print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1;
print "ok $test\n";
$test++;

$_ = 'aaa';
pos = 1;
@a = /\Ga/g;
print "not " unless "@a" eq "a a";
print "ok $test\n";
$test++;

$str = 'abcde';
pos $str = 2;

print "not " if $str =~ /^\G/;
print "ok $test\n";
$test++;

print "not " if $str =~ /^.\G/;
print "ok $test\n";
$test++;

print "not " unless $str =~ /^..\G/;
print "ok $test\n";
$test++;

print "not " if $str =~ /^...\G/;
print "ok $test\n";
$test++;

print "not " unless $str =~ /.\G./ and $& eq 'bc';
print "ok $test\n";
$test++;

print "not " unless $str =~ /\G../ and $& eq 'cd';
print "ok $test\n";
$test++;

undef $foo; undef $bar;
print "#'$str','$foo','$bar'\nnot "
    unless $str =~ /b(?{$foo = $_; $bar = pos})c/ 
	and $foo eq 'abcde' and $bar eq 2;
print "ok $test\n";
$test++;

undef $foo; undef $bar;
pos $str = undef;
print "#'$str','$foo','$bar'\nnot "
    unless $str =~ /b(?{$foo = $_; $bar = pos})c/g 
	and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3;
print "ok $test\n";
$test++;

$_ = $str;

undef $foo; undef $bar;
print "#'$str','$foo','$bar'\nnot "
    unless /b(?{$foo = $_; $bar = pos})c/ 
	and $foo eq 'abcde' and $bar eq 2;
print "ok $test\n";
$test++;

undef $foo; undef $bar;
print "#'$str','$foo','$bar'\nnot "
    unless /b(?{$foo = $_; $bar = pos})c/g 
	and $foo eq 'abcde' and $bar eq 2 and pos eq 3;
print "ok $test\n";
$test++;

undef $foo; undef $bar;
pos = undef;
1 while /b(?{$foo = $_; $bar = pos})c/g;
print "#'$str','$foo','$bar'\nnot "
    unless $foo eq 'abcde' and $bar eq 2 and not defined pos;
print "ok $test\n";
$test++;

undef $foo; undef $bar;
$_ = 'abcde|abcde';
print "#'$str','$foo','$bar','$_'\nnot "
    unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' 
	and $bar eq 8 and $_ eq 'axde|axde';
print "ok $test\n";
$test++;

@res = ();
# List context:
$_ = 'abcde|abcde';
@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
@res = map {defined $_ ? "'$_'" : 'undef'} @res;
$res = "@res";
print "#'@res' '$_'\nnot "
    unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'";
print "ok $test\n";
$test++;

@res = ();
@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
@res = map {defined $_ ? "'$_'" : 'undef'} @res;
$res = "@res";
print "#'@res' '$_'\nnot "
    unless "@res" eq
  "'' 'ab' 'cde|abcde' " .
  "'' 'abc' 'de|abcde' " .
  "'abcd' 'e|' 'abcde' " .
  "'abcde|' 'ab' 'cde' " .
  "'abcde|' 'abc' 'de'" ;
print "ok $test\n";
$test++;

#Some more \G anchor checks
$foo='aabbccddeeffgg';

pos($foo)=1;

$foo=~/.\G(..)/g;
print "not " unless($1 eq 'ab');
print "ok $test\n";
$test++;

pos($foo) += 1;
$foo=~/.\G(..)/g;
print "not " unless($1 eq 'cc');
print "ok $test\n";
$test++;

pos($foo) += 1;
$foo=~/.\G(..)/g;
print "not " unless($1 eq 'de');
print "ok $test\n";
$test++;

print "not " unless $foo =~ /\Gef/g;
print "ok $test\n";
$test++;

undef pos $foo;

$foo=~/\G(..)/g;
print "not " unless($1  eq 'aa');
print "ok $test\n";
$test++;

$foo=~/\G(..)/g;
print "not " unless($1  eq 'bb');
print "ok $test\n";
$test++;

pos($foo)=5;
$foo=~/\G(..)/g;
print "not " unless($1  eq 'cd');
print "ok $test\n";
$test++;

$_='123x123'; 
@res = /(\d*|x)/g;
print "not " unless('123||x|123|' eq join '|', @res);
print "ok $test\n";
$test++;

# see if matching against temporaries (created via pp_helem()) is safe
{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g;
print "$1\n";
$test++;

# See if $i work inside (?{}) in the presense of saved substrings and
# changing $_
@a = qw(foo bar);
@b = ();
s/(\w)(?{push @b, $1})/,$1,/g for @a;

print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r");
print "ok $test\n";
$test++;

print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,");
print "ok $test\n";
$test++;

$brackets = qr{
	         {  (?> [^{}]+ | (??{ $brackets }) )* }
	      }x;

"{{}" =~ $brackets;
print "ok $test\n";		# Did we survive?
$test++;

"something { long { and } hairy" =~ $brackets;
print "ok $test\n";		# Did we survive?
$test++;

"something { long { and } hairy" =~ m/((??{ $brackets }))/;
print "not " unless $1 eq "{ and }";
print "ok $test\n";
$test++;

$_ = "a-a\nxbb";
pos=1;
m/^-.*bb/mg and print "not ";
print "ok $test\n";
$test++;

$text = "aaXbXcc";
pos($text)=0;
$text =~ /\GXb*X/g and print 'not ';
print "ok $test\n";
$test++;

$text = "xA\n" x 500;
$text =~ /^\s*A/m and print 'not ';
print "ok $test\n";
$test++;

$text = "abc dbf";
@res = ($text =~ /.*?(b).*?\b/g);
"@res" eq 'b b' or print 'not ';
print "ok $test\n";
$test++;

@a = map chr,0..255;

@b = grep(/\S/,@a);
@c = grep(/[^\s]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\S/,@a);
@c = grep(/[\S]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\s/,@a);
@c = grep(/[^\S]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\s/,@a);
@c = grep(/[\s]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\D/,@a);
@c = grep(/[^\d]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\D/,@a);
@c = grep(/[\D]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\d/,@a);
@c = grep(/[^\D]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\d/,@a);
@c = grep(/[\d]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\W/,@a);
@c = grep(/[^\w]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\W/,@a);
@c = grep(/[\W]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\w/,@a);
@c = grep(/[^\W]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

@b = grep(/\w/,@a);
@c = grep(/[\w]/,@a);
print "not " if "@b" ne "@c";
print "ok $test\n";
$test++;

# see if backtracking optimization works correctly
"\n\n" =~ /\n  $ \n/x or print "not ";
print "ok $test\n";
$test++;

"\n\n" =~ /\n* $ \n/x or print "not ";
print "ok $test\n";
$test++;

"\n\n" =~ /\n+ $ \n/x or print "not ";
print "ok $test\n";
$test++;

[] =~ /^ARRAY/ or print "# [] \nnot ";
print "ok $test\n";
$test++;

eval << 'EOE';
{
 package S;
 use overload '""' => sub { 'Object S' };
 sub new { bless [] }
}
$a = 'S'->new;
EOE

$a and $a =~ /^Object\sS/ or print "# '$a' \nnot ";
print "ok $test\n";
$test++;

# test result of match used as match (!)
'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not ";
print "ok $test\n";
$test++;

'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not ";
print "ok $test\n";
$test++;

$w = 0;
{
    local $SIG{__WARN__} = sub { $w = 1 };
    local $^W = 1;
	$w = 1 if ("1\n" x 102) =~ /^\s*\n/m;
}
print $w ? "not " : "", "ok $test\n";
$test++;

my %space = ( spc   => " ",
	      tab   => "\t",
	      cr    => "\r",
	      lf    => "\n",
	      ff    => "\f",
# There's no \v but the vertical tabulator seems miraculously
# be 11 both in ASCII and EBCDIC.
	      vt    => chr(11),
	      false => "space" );

my @space0 = sort grep { $space{$_} =~ /\s/ }          keys %space;
my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space;
my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space;

print "not " unless "@space0" eq "cr ff lf spc tab";
print "ok $test # @space0\n";
$test++;

print "not " unless "@space1" eq "cr ff lf spc tab vt";
print "ok $test # @space1\n";
$test++;

print "not " unless "@space2" eq "spc tab";
print "ok $test # @space2\n";
$test++;
 
# bugid 20001021.005 - this caused a SEGV
print "not " unless undef =~ /^([^\/]*)(.*)$/;
print "ok $test\n";
$test++;

{
  # japhy -- added 03/03/2001
  () = (my $str = "abc") =~ /(...)/;
  $str = "def";
  print "not " if $1 ne "abc";
  print "ok $test\n";
  $test++;
}