This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c7461d41d3b7bd70130aa9d52dd0770ce8928f52
[perl5.git] / t / re / qr.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 plan tests => 6;
10
11 my $rx = qr//;
12
13 is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default");
14
15
16 # Make sure /$qr/ doesn’t clobber match vars before the match (bug 70764).
17 {
18  my $output = '';
19  my $rx = qr/o/;
20  my $a = "ooaoaoao";
21
22  my $foo = 0;
23  $foo += () = ($a =~ /$rx/g);
24  $output .= "$foo\n"; # correct
25
26  $foo = 0;
27  for ($foo += ($a =~ /o/); $' && ($' =~ /o/) && ($foo++) ; ) { ; }
28  $output .= "1: $foo\n"; # No error
29
30  $foo = 0;
31  for ($foo += ($a =~ /$rx/); $' && ($' =~ /$rx/) && ($foo++) ; ) { ; }
32  $output .= "2: $foo\n"; # initialization warning, incorrect results
33
34  is $output, "5\n1: 5\n2: 5\n", '$a_match_var =~ /$qr/';
35 }
36 for my $_($'){
37  my $output = '';
38  my $rx = qr/o/;
39  my $a = "ooaoaoao";
40
41  my $foo = 0;
42  $foo += () = ($a =~ /$rx/g);
43  $output .= "$foo\n"; # correct
44
45  $foo = 0;
46  for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; }
47  $output .= "1: $foo\n"; # No error
48
49  $foo = 0;
50  for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; }
51  $output .= "2: $foo\n"; # initialization warning, incorrect results
52
53  is $output, "5\n1: 5\n2: 5\n", '/$qr/ with my $_ aliased to a match var';
54 }
55 for($'){
56  my $output = '';
57  my $rx = qr/o/;
58  my $a = "ooaoaoao";
59
60  my $foo = 0;
61  $foo += () = ($a =~ /$rx/g);
62  $output .= "$foo\n"; # correct
63
64  $foo = 0;
65  for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; }
66  $output .= "1: $foo\n"; # No error
67
68  $foo = 0;
69  for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; }
70  $output .= "2: $foo\n"; # initialization warning, incorrect results
71
72  is $output, "5\n1: 5\n2: 5\n", q|/$qr/ with $'_ aliased to a match var|;
73 }
74
75 # Make sure /$qr/ calls get-magic on its LHS (bug ~~~~~).
76 {
77  my $scratch;
78  sub qrBug::TIESCALAR{bless[], 'qrBug'}
79  sub qrBug::FETCH { $scratch .= "[fetching]"; 'glat' }
80  tie my $flile, "qrBug";
81  $flile =~ qr/(?:)/;
82  is $scratch, "[fetching]", '/$qr/ with magical LHS';
83 }
84
85 {
86     # [perl 72922]: A 'copy' of a Regex object which has magic should not crash
87     # When a Regex object was copied and the copy weaken then the original regex object
88     # could no longer be 'copied' with qr//
89
90     my $prog = tempfile();
91     open my $fh, ">", $prog or die "Can't write to tempfile";
92     print $fh <<'EOTEST';
93 require "./test.pl";
94 $verbose = 1;
95 use Scalar::Util 'weaken';
96 sub s1 {
97     my $re = qr/abcdef/;
98     my $re_copy1 = $re;
99     my $re_weak_copy = $re;;
100     weaken($re_weak_copy);
101     my $re_copy2 = qr/$re/;
102
103     my $str_re = "$re";
104     is("$$re_weak_copy", $str_re, "weak copy equals original");
105     is("$re_copy1", $str_re, "copy1 equals original");
106     is("$re_copy2", $str_re, "copy2 equals original");
107
108     my $refcnt_start = Internals::SvREFCNT($$re_weak_copy);
109
110     undef $re;
111     is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt decreased");
112     is("$re_weak_copy", $str_re, "weak copy still equals original");
113
114     undef $re_copy2;
115     is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt not decreased");
116     is("$re_weak_copy", $str_re, "weak copy still equals original");
117 }
118 s1();
119 s1();
120 EOTEST
121     close $fh;
122
123     my $out = runperl(stderr => 1, progfile => $prog);
124     unlink $prog;
125
126     my $expected = <<'EOOUT';
127 ok 1 - weak copy equals original
128 ok 2 - copy1 equals original
129 ok 3 - copy2 equals original
130 ok 4 - refcnt decreased
131 ok 5 - weak copy still equals original
132 ok 6 - refcnt not decreased
133 ok 7 - weak copy still equals original
134 ok 8 - weak copy equals original
135 ok 9 - copy1 equals original
136 ok 10 - copy2 equals original
137 ok 11 - refcnt decreased
138 ok 12 - weak copy still equals original
139 ok 13 - refcnt not decreased
140 ok 14 - weak copy still equals original
141 EOOUT
142
143     is ($out, $expected, '[perl #72922] copy of a regex of which a weak copy exist');
144 }