view release on metacpan or  search on metacpan

t/perl/pat.t  view on Meta::CPAN

print "ok 677\n" if @a == 7 && "@a" eq "f o o \n b a r";

@a = ("foo\nbar" =~ /\C/g);
print "ok 678\n" if @a == 7 && "@a" eq "f o o \n b a r";

@a = ("foo\nbar" =~ /\C/gs);
print "ok 679\n" if @a == 7 && "@a" eq "f o o \n b a r";

@a = ("foo\n\x{100}bar" =~ /./g);
print "ok 680\n" if @a == 7 && "@a" eq "f o o \x{100} b a r";

@a = ("foo\n\x{100}bar" =~ /./gs);
print "ok 681\n" if @a == 8 && "@a" eq "f o o \n \x{100} b a r";

($a, $b) = map { chr } ord('A') == 65 ? (0xc4, 0x80) : (0x8c, 0x41);

@a = ("foo\n\x{100}bar" =~ /\C/g);
print "ok 682\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r";

@a = ("foo\n\x{100}bar" =~ /\C/gs);
print "ok 683\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r";

{
    # [ID 20010814.004] pos() doesn't work when using =~m// in list context
    $_ = "ababacadaea";
    $a = join ":", /b./gc;
    $b = join ":", /a./gc;
    $c = pos;
    print "$a $b $c" eq 'ba:ba ad:ae 10' ? "ok 684\n" : "not ok 684\t# $a $b $c\n";
}

{
    # [ID 20010407.006] matching utf8 return values from functions does not work

    package ID_20010407_006;

    sub x {
	"a\x{1234}";
    }

    my $x = x;
    my $y;

    $x =~ /(..)/; $y = $1;
    print "not " unless length($y) == 2 && $y eq $x;
    print "ok 685\n";

    x  =~ /(..)/; $y = $1;
    print "not " unless length($y) == 2 && $y eq $x;
    print "ok 686\n";
}


$test = 687;

# Force scalar context on the patern match
sub ok ($;$) {
    my($ok, $name) = @_;

    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
        ($name||$Message)."\tLine ".((caller)[2]);

    printf "# Failed test at line %d\n", (caller)[2] unless $ok;

    $test++;
    return $ok;
}

{
    # Check that \x## works. 5.6.1 and 5.005_03 fail some of these.
    $x = "\x4e" . "E";
    ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched.");

    $x = "\x4e" . "i";
    ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)");

    $x = "\x4" . "j";
    ok ($x =~ /^\x4j$/,  "Check that invalid hex digit stops it (1)");

    $x = "\x0" . "k";
    ok ($x =~ /^\xk$/,   "Check that invalid hex digit stops it (0)");

    $x = "\x0" . "x";
    ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0");

    $x = "\x0" . "xa";
    ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa");

    $x = "\x9" . "_b";
    ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b");

    print "# and now again in [] ranges\n";

    $x = "\x4e" . "E";
    ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched.");

    $x = "\x4e" . "i";
    ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)");

    $x = "\x4" . "j";
    ok ($x =~ /^[\x4j]{2}$/,  "Check that invalid hex digit stops it (1)");

    $x = "\x0" . "k";
    ok ($x =~ /^[\xk]{2}$/,   "Check that invalid hex digit stops it (0)");

    $x = "\x0" . "x";
    ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0");

    $x = "\x0" . "xa";
    ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa");

    $x = "\x9" . "_b";
    ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b");

}

{
    # Check that \x{##} works. 5.6.1 fails quite a few of these.

    $x = "\x9b";
    ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b");

    $x = "\x9b" . "y";

t/perl/pat.t  view on Meta::CPAN

        <<<right>>>
        <<stuff1>and<stuff2>><<<<right>>>>
    );

    local $_='<<<stuff1>and<stuff2>><<<<right>>>>>';
    ok(/^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/,
        "Recursion should match");
    ok(@stack==@expect)
        or skip("Won't test individual results as count isn't equal",
                0+@expect);
    foreach my $idx (@expect) {
        ok($expect[$idx] eq $stack[$idx], 
            "Expecting '$expect' at stack pos #$idx");
    }
        
}
{
    my $s='123453456';
    $s=~s/(?<digits>\d+)\k<digits>/$+{digits}/;
    ok($s eq '123456','Named capture (angle brackets) s///');
    $s='123453456';
    $s=~s/(?'digits'\d+)\k'digits'/$+{digits}/;
    ok($s eq '123456','Named capture (single quotes) s///');    
}

{
    my @ary = (
	pack('U', 0x00F1),            # n-tilde
	'_'.pack('U', 0x00F1),        # _ + n-tilde
	'c'.pack('U', 0x0327),        # c + cedilla
	pack('U*', 0x00F1, 0x0327),   # n-tilde + cedilla
	'a'.pack('U', 0x00B2),        # a + superscript two
	pack('U', 0x0391),            # ALPHA
	pack('U', 0x0391).'2',        # ALPHA + 2
	pack('U', 0x0391).'_',        # ALPHA + _
    );
    for my $uni (@ary) {
	my ($r1, $c1, $r2, $c2) = eval qq{
	    use utf8;
	    scalar("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/),
		\$+{${uni}},
	    scalar("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/),
		\$+{${uni}};
	};
	ok($r1,                         "Named capture UTF (?'')");
	ok(defined $c1 && $c1 eq 'foo', "Named capture UTF \%+");
	ok($r2,                         "Named capture UTF (?<>)");
	ok(defined $c2 && $c2 eq 'bar', "Named capture UTF \%+");
    }
}

sub iseq($$;$) { 
    my ( $got, $expect, $name)=@_;
    
    $_=defined($_) ? "'$_'" : "undef"
        for $got, $expect;
        
    my $ok=  $got eq $expect;
        
    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
        ($name||$Message)."\tLine ".((caller)[2]);

    printf "# Failed test at line %d\n".
           "# expected: %s\n". 
           "#   result: %s\n", 
           (caller)[2], $expect, $got
        unless $ok;

    $test++;
    return $ok;
}   
{
    my $s='foo bar baz';
    my (@k,@v,@fetch,$res);
    my $count= 0;
    my @names=qw($+{A} $+{B} $+{C});
    if ($s=~/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/) {
        while (my ($k,$v)=each(%+)) {
            $count++;
        }
        @k=sort keys(%+);
        @v=sort values(%+);
        $res=1;
        push @fetch,
            [ "$+{A}", "$1" ],
            [ "$+{B}", "$2" ],
            [ "$+{C}", "$3" ],
        ;
    } 
    foreach (0..2) {
        if ($fetch[$_]) {
            iseq($fetch[$_][0],$fetch[$_][1],$names[$_]);
        } else {
            ok(0, $names[$_]);
        }
    }
    iseq($res,1,"$s~=/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/");
    iseq($count,3,"Got 3 keys in %+ via each");
    iseq(0+@k, 3, 'Got 3 keys in %+ via keys');
    iseq("@k","A B C", "Got expected keys");
    iseq("@v","bar baz foo", "Got expected values");
    eval'
        print for $+{this_key_doesnt_exist};
    ';
    ok(!$@,'lvalue $+{...} should not throw an exception');
}
{
    my $s='foo bar baz';
    my @res;
    if ('1234'=~/(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
        foreach my $name (sort keys(%-)) {
            my $ary = $-{$name};
            foreach my $idx (0..$#$ary) {
                push @res,"$name:$idx:$ary->[$idx]";
            }
        }
    }
    my @expect=qw(A:0:1 A:1:3 B:0:2 B:1:4);
    iseq("@res","@expect","Check %-");
    eval'
        print for $-{this_key_doesnt_exist};
    ';
    ok(!$@,'lvalue $-{...} should not throw an exception');
}
# stress test CURLYX/WHILEM.
#