t/re/re.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10 use warnings;
  11 use POSIX;
  12
  13 use re qw(is_regexp regexp_pattern
  14           regname regnames regnames_count);
  15 {
  16     use feature 'unicode_strings';  # Force 'u' pat mod
  17     my $qr=qr/foo/pi;
  18     no feature 'unicode_strings';
  19     my $rx = $$qr;
  20
  21     ok(is_regexp($qr),'is_regexp(REGEXP ref)');
  22     ok(is_regexp($rx),'is_regexp(REGEXP)');
  23     ok(!is_regexp(''),'is_regexp("")');
  24
  25     is((regexp_pattern($qr))[0],'foo','regexp_pattern[0] (ref)');
  26     is((regexp_pattern($qr))[1],'uip','regexp_pattern[1] (ref)');
  27     is(regexp_pattern($qr),'(?^upi:foo)','scalar regexp_pattern (ref)');
  28
  29     is((regexp_pattern($rx))[0],'foo','regexp_pattern[0] (bare REGEXP)');
  30     is((regexp_pattern($rx))[1],'uip','regexp_pattern[1] (bare REGEXP)');
  31     is(regexp_pattern($rx),'(?^upi:foo)', 'scalar regexp_pattern (bare REGEXP)');
  32
  33     ok(!regexp_pattern(''),'!regexp_pattern("")');
  34 }
  35
  36 if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
  37     my @names = sort +regnames();
  38     is("@names","A B","regnames");
  39     @names = sort +regnames(0);
  40     is("@names","A B","regnames");
  41     my $names = regnames();
  42     is($names, "B", "regnames in scalar context");
  43     @names = sort +regnames(1);
  44     is("@names","A B C","regnames");
  45     is(join("", @{regname("A",1)}),"13");
  46     is(join("", @{regname("B",1)}),"24");
  47     {
  48         if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
  49             is(regnames_count(),2);
  50         } else {
  51             ok(0); ok(0);
  52         }
  53     }
  54     is(regnames_count(),3);
  55 }
  56
  57 {
  58     my ($pat, $mods);
  59     $|=1;
  60
  61     my $re = qr/a/d;
  62     ($pat, $mods) = regexp_pattern($re);
  63     is($mods, "", "Verify /d results in default mod");
  64     $re = qr/a/u;
  65     ($pat, $mods) = regexp_pattern($re);
  66     is($mods, "u", "Verify /u is understood");
  67     $re = qr/a/l;
  68     ($pat, $mods) = regexp_pattern($re);
  69     is($mods, "l", "Verify /l is understood");
  70     $re = qr/a/a;
  71     ($pat, $mods) = regexp_pattern($re);
  72     is($mods, "a", "Verify /a is understood");
  73     $re = qr/a/aa;
  74     ($pat, $mods) = regexp_pattern($re);
  75     is($mods, "aa", "Verify /aa is understood");
  76     diag($mods);
  77     $pat = regexp_pattern($re);
  78     diag($pat);
  79 }
  80
  81 {
  82     # tests for new regexp flags
  83     my $text = "\xE4";
  84     my $check;
  85
  86     {
  87         # check u/d-flag without setting a locale
  88         $check = $text =~ /(?u)\w/;
  89         ok( $check );
  90         $check = $text =~ /(?d)\w/;
  91         ok( !$check );
  92     }
  93
  94     SKIP: {
  95         my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'de_DE.ISO-8859-1' );
  96         if ( !$current_locale || $current_locale ne 'de_DE.ISO-8859-1' ) {
  97             skip( 'cannot use locale de_DE.ISO-8859-1', 3 );
  98         }
  99
 100         $check = $text =~ /(?u)\w/;
 101         ok( $check );
 102         $check = $text =~ /(?d)\w/;
 103         ok( !$check );
 104         $check = $text =~ /(?l)\w/;
 105         ok( $check );
 106     }
 107
 108     SKIP: {
 109         my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'C' );
 110         if ( !$current_locale || $current_locale ne 'C' ) {
 111             skip( 'cannot set locale C', 3 );
 112         }
 113
 114         $check = $text =~ /(?u)\w/;
 115         ok( $check );
 116         $check = $text =~ /(?d)\w/;
 117         ok( !$check );
 118         $check = $text =~ /(?l)\w/;
 119         ok( !$check );
 120     }
 121 }
 122
 123
 124     { # Keep these tests last, as whole script will be interrupted if times out
 125         # Bug #72998; this can loop
 126         watchdog(2);
 127         eval '"\x{100}\x{FB00}" =~ /\x{100}\N{U+66}+/i';
 128         pass("Didn't loop");
 129
 130         # Bug #78058; this can loop
 131         no warnings;    # Because the 8 may be warned on
 132         eval 'qr/\18/';
 133         pass(q"qr/\18/ didn't loop");
 134     }
 135
 136 # New tests above this line, don't forget to update the test count below!
 137 BEGIN { plan tests => 33 }
 138 # No tests here!