view release on metacpan or  search on metacpan

t/re/pat_advanced.t  view on Meta::CPAN

        # Test named commits and the $REGERROR var
	my $message = '$REGERROR';
        local $REGERROR;
        for my $word (qw (bar baz bop)) {
            $REGERROR = "";
            "aaaaa$word" =~
              /a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/;
            is($REGERROR, $word, $message);
        }
    }

    {
        #Mindnumbingly simple test of (*THEN)
        for ("ABC","BAX") {
            ok /A (*THEN) X | B (*THEN) C/x, "Simple (*THEN) test";
        }
    }

    {
        my $message = "Relative Recursion";
        my $parens = qr/(\((?:[^()]++|(?-1))*+\))/;
        local $_ = 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))';
        my ($all, $one, $two) = ('', '', '');
        ok(m/foo $parens \s* \+ \s* bar $parens/x, $message);
        is($1, '((2*3)+4-3)', $message);
        is($2, '(2*(3+4)-1*(2-3))', $message);
        is($&, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))', $message);
        is($&, $_, $message);
    }

    {
        my $spaces="      ";
        local $_ = join 'bar', $spaces, $spaces;
        our $count = 0;
        s/(?>\s+bar)(?{$count++})//g;
        is($_, $spaces, "SUSPEND final string");
        is($count, 1, "Optimiser should have prevented more than one match");
    }

    {
        # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus>
        my $dow_name = "nada";
        my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ " .
                     "C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/";
        my $time_string = "D\x{e9} C\x{e9}adaoin";
        eval $parser;
        ok !$@, "Test Eval worked";
        is($dow_name, $time_string, "UTF-8 trie common prefix extraction");
    }

    {
        my $v;
        ($v = 'bar') =~ /(\w+)/g;
        $v = 'foo';
        is("$1", 'bar',
	   '$1 is safe after /g - may fail due to specialized config in pp_hot.c');
    }

    {
        my $message = "http://nntp.perl.org/group/perl.perl5.porters/118663";
        my $qr_barR1 = qr/(bar)\g-1/;
        like("foobarbarxyz", $qr_barR1, $message);
        like("foobarbarxyz", qr/foo${qr_barR1}xyz/, $message);
        like("foobarbarxyz", qr/(foo)${qr_barR1}xyz/, $message);
        like("foobarbarxyz", qr/(foo)(bar)\g{-1}xyz/, $message);
        like("foobarbarxyz", qr/(foo${qr_barR1})xyz/, $message);
        like("foobarbarxyz", qr/(foo(bar)\g{-1})xyz/, $message);
    }

    {
        my $message = '$REGMARK';
        our @r = ();
        local $REGMARK;
        local $REGERROR;
        like('foofoo', qr/foo (*MARK:foo) (?{push @r,$REGMARK}) /x, $message);
        is("@r","foo", $message);
        is($REGMARK, "foo", $message);
        unlike('foofoo', qr/foo (*MARK:foo) (*FAIL) /x, $message);
        is($REGMARK, '', $message);
        is($REGERROR, 'foo', $message);
    }

    {
        my $message = '\K test';
        my $x;
        $x = "abc.def.ghi.jkl";
        $x =~ s/.*\K\..*//;
        is($x, "abc.def.ghi", $message);

        $x = "one two three four";
        $x =~ s/o+ \Kthree//g;
        is($x, "one two  four", $message);

        $x = "abcde";
        $x =~ s/(.)\K/$1/g;
        is($x, "aabbccddee", $message);
    }

    {
        sub kt {
            return '4' if $_[0] eq '09028623';
        }
        # Nested EVAL using PL_curpm (via $1 or friends)
        my $re;
        our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x;
        $re = qr/^ ( (??{ $grabit }) ) $ /x;
        my @res = '0902862349' =~ $re;
        is(join ("-", @res), "0902862349",
	   'PL_curpm is set properly on nested eval');

        our $qr = qr/ (o) (??{ $1 }) /x;
        ok 'boob'=~/( b (??{ $qr }) b )/x && 1, "PL_curpm, nested eval";
    }

    {
        use charnames ":full";
        like "\N{ROMAN NUMERAL ONE}", qr/\p{Alphabetic}/, "I =~ Alphabetic";
        like "\N{ROMAN NUMERAL ONE}", qr/\p{Uppercase}/,  "I =~ Uppercase";
        unlike "\N{ROMAN NUMERAL ONE}", qr/\p{Lowercase}/,  "I !~ Lowercase";
        like "\N{ROMAN NUMERAL ONE}", qr/\p{IDStart}/,    "I =~ ID_Start";
        like "\N{ROMAN NUMERAL ONE}", qr/\p{IDContinue}/, "I =~ ID_Continue";
        like "\N{SMALL ROMAN NUMERAL ONE}", qr/\p{Alphabetic}/, "i =~ Alphabetic";
        unlike "\N{SMALL ROMAN NUMERAL ONE}", qr/\p{Uppercase}/,  "i !~ Uppercase";
        like "\N{SMALL ROMAN NUMERAL ONE}", qr/\p{Uppercase}/i,  "i =~ Uppercase under /i";
        unlike "\N{SMALL ROMAN NUMERAL ONE}", qr/\p{Titlecase}/,  "i !~ Titlecase";
        like "\N{SMALL ROMAN NUMERAL ONE}", qr/\p{Titlecase}/i,  "i =~ Titlecase under /i";
        like "\N{ROMAN NUMERAL ONE}", qr/\p{Lowercase}/i,  "I =~ Lowercase under /i";