This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add missing bug numbers
[perl5.git] / t / re / qr.t
CommitLineData
9bc340e7
AB
1#!./perl -w
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 require './test.pl';
7}
8
d3693443 9plan tests => 6;
9bc340e7
AB
10
11my $rx = qr//;
12
13is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default");
69dc4b30
FC
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}
36for 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}
55for($'){
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}
455d9033 74
92c404cd 75# Make sure /$qr/ calls get-magic on its LHS (bug 71470).
455d9033
FC
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}
d3693443
B
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';
93require "./test.pl";
94$verbose = 1;
95use Scalar::Util 'weaken';
96sub 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}
118s1();
119s1();
120EOTEST
121 close $fh;
122
123 my $out = runperl(stderr => 1, progfile => $prog);
124 unlink $prog;
125
126 my $expected = <<'EOOUT';
127ok 1 - weak copy equals original
128ok 2 - copy1 equals original
129ok 3 - copy2 equals original
130ok 4 - refcnt decreased
131ok 5 - weak copy still equals original
132ok 6 - refcnt not decreased
133ok 7 - weak copy still equals original
134ok 8 - weak copy equals original
135ok 9 - copy1 equals original
136ok 10 - copy2 equals original
137ok 11 - refcnt decreased
138ok 12 - weak copy still equals original
139ok 13 - refcnt not decreased
140ok 14 - weak copy still equals original
141EOOUT
142
143 is ($out, $expected, '[perl #72922] copy of a regex of which a weak copy exist');
144}