This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
replace leave_common() with leave_adjust_stacks()
[perl5.git] / t / op / grep.t
CommitLineData
fd3835b3
GS
1#!./perl
2
3#
4# grep() and map() tests
5#
6
cb9881c1
RGS
7BEGIN {
8 chdir 't' if -d 't';
9 @INC = qw(. ../lib);
1ae3d757 10 require "./test.pl";
fd3835b3
GS
11}
12
75bc488d 13plan( tests => 67 );
cb9881c1 14
fd3835b3 15{
cb9881c1
RGS
16 my @lol = ([qw(a b c)], [], [qw(1 2 3)]);
17 my @mapped = map {scalar @$_} @lol;
18 cmp_ok("@mapped", 'eq', "3 0 3", 'map scalar list of list');
19
20 my @grepped = grep {scalar @$_} @lol;
21 cmp_ok("@grepped", 'eq', "$lol[0] $lol[2]", 'grep scalar list of list');
22 $test++;
23
24 @grepped = grep { $_ } @mapped;
25 cmp_ok( "@grepped", 'eq', "3 3", 'grep basic');
fd3835b3
GS
26}
27
2c38e13d 28{
cb9881c1
RGS
29 my @res;
30
31 @res = map({$_} ("geronimo"));
32 cmp_ok( scalar(@res), '==', 1, 'basic map nr');
33 cmp_ok( $res[0], 'eq', 'geronimo', 'basic map is');
34
35 @res = map
36 ({$_} ("yoyodyne"));
37 cmp_ok( scalar(@res), '==', 1, 'linefeed map nr');
38 cmp_ok( $res[0], 'eq', 'yoyodyne', 'linefeed map is');
39
40 @res = (map(
41 {a =>$_},
42 ("chobb")))[0]->{a};
43 cmp_ok( scalar(@res), '==', 1, 'deref map nr');
44 cmp_ok( $res[0], 'eq', 'chobb', 'deref map is');
45
46 @res = map {$_} ("geronimo");
47 cmp_ok( scalar(@res), '==', 1, 'no paren basic map nr');
48 cmp_ok( $res[0], 'eq', 'geronimo', 'no paren basic map is');
49
50 @res = map
51 {$_} ("yoyodyne");
52 cmp_ok( scalar(@res), '==', 1, 'no paren linefeed map nr');
53 cmp_ok( $res[0], 'eq', 'yoyodyne', 'no paren linefeed map is');
54
55 @res = (map
56 {a =>$_},
57 ("chobb"))[0]->{a};
58 cmp_ok( scalar(@res), '==', 1, 'no paren deref map nr');
59 cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref map is');
60
61 my $x = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\n";
62
63 @res = map($_&$x,("sferics\n"));
64 cmp_ok( scalar(@res), '==', 1, 'binand map nr 1');
65 cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 1');
66
67 @res = map
68 ($_ & $x, ("sferics\n"));
69 cmp_ok( scalar(@res), '==', 1, 'binand map nr 2');
70 cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 2');
71
72 @res = map { $_ & $x } ("sferics\n");
73 cmp_ok( scalar(@res), '==', 1, 'binand map nr 3');
74 cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 3');
75
76 @res = map
77 { $_&$x } ("sferics\n");
78 cmp_ok( scalar(@res), '==', 1, 'binand map nr 4');
79 cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 4');
80
81 @res = grep({$_} ("geronimo"));
82 cmp_ok( scalar(@res), '==', 1, 'basic grep nr');
83 cmp_ok( $res[0], 'eq', 'geronimo', 'basic grep is');
84
85 @res = grep
86 ({$_} ("yoyodyne"));
87 cmp_ok( scalar(@res), '==', 1, 'linefeed grep nr');
88 cmp_ok( $res[0], 'eq', 'yoyodyne', 'linefeed grep is');
89
90 @res = grep
91 ({a=>$_}->{a},
92 ("chobb"));
93 cmp_ok( scalar(@res), '==', 1, 'deref grep nr');
94 cmp_ok( $res[0], 'eq', 'chobb', 'deref grep is');
95
96 @res = grep {$_} ("geronimo");
97 cmp_ok( scalar(@res), '==', 1, 'no paren basic grep nr');
98 cmp_ok( $res[0], 'eq', 'geronimo', 'no paren basic grep is');
99
100 @res = grep
101 {$_} ("yoyodyne");
102 cmp_ok( scalar(@res), '==', 1, 'no paren linefeed grep nr');
103 cmp_ok( $res[0], 'eq', 'yoyodyne', 'no paren linefeed grep is');
104
105 @res = grep {a=>$_}->{a}, ("chobb");
106 cmp_ok( scalar(@res), '==', 1, 'no paren deref grep nr');
107 cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref grep is');
108
109 @res = grep
110 {a=>$_}->{a}, ("chobb");
111 cmp_ok( scalar(@res), '==', 1, 'no paren deref linefeed nr');
112 cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref linefeed is');
113
114 @res = grep($_&"X", ("bodine"));
115 cmp_ok( scalar(@res), '==', 1, 'binand X grep nr');
116 cmp_ok( $res[0], 'eq', 'bodine', 'binand X grep is');
117
118 @res = grep
119 ($_&"X", ("bodine"));
120 cmp_ok( scalar(@res), '==', 1, 'binand X linefeed grep nr');
121 cmp_ok( $res[0], 'eq', 'bodine', 'binand X linefeed grep is');
122
123 @res = grep {$_&"X"} ("bodine");
124 cmp_ok( scalar(@res), '==', 1, 'no paren binand X grep nr');
125 cmp_ok( $res[0], 'eq', 'bodine', 'no paren binand X grep is');
126
127 @res = grep
128 {$_&"X"} ("bodine");
129 cmp_ok( scalar(@res), '==', 1, 'no paren binand X linefeed grep nr');
130 cmp_ok( $res[0], 'eq', 'bodine', 'no paren binand X linefeed grep is');
2c38e13d 131}
fb14229d 132
fb14229d 133{
cb9881c1
RGS
134 # Tests for "for" in "map" and "grep"
135 # Used to dump core, bug [perl #17771]
136
fb14229d
RGS
137 my @x;
138 my $y = '';
139 @x = map { $y .= $_ for 1..2; 1 } 3..4;
cb9881c1
RGS
140 cmp_ok( "@x,$y",'eq',"1 1,1212", '[perl #17771] for in map 1');
141
fb14229d
RGS
142 $y = '';
143 @x = map { $y .= $_ for 1..2; $y .= $_ } 3..4;
cb9881c1
RGS
144 cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 2');
145
fb14229d
RGS
146 $y = '';
147 @x = map { for (1..2) { $y .= $_ } $y .= $_ } 3..4;
cb9881c1
RGS
148 cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 3');
149
fb14229d
RGS
150 $y = '';
151 @x = grep { $y .= $_ for 1..2; 1 } 3..4;
cb9881c1
RGS
152 cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 1');
153
fb14229d
RGS
154 $y = '';
155 @x = grep { for (1..2) { $y .= $_ } 1 } 3..4;
cb9881c1 156 cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 2');
6c8d78fb
HS
157
158 # Add also a sample test from [perl #18153]. (The same bug).
159 $a = 1; map {if ($a){}} (2);
cb9881c1 160 pass( '[perl #18153] (not dead yet)' ); # no core dump is all we need
fb14229d 161}
6c8d78fb 162
b3c0f1bd
DN
163{
164 sub add_an_x(@){
165 map {"${_}x"} @_;
166 };
cb9881c1 167 cmp_ok( join("-",add_an_x(1,2,3,4)), 'eq', "1x-2x-3x-4x", 'add-an-x');
b3c0f1bd
DN
168}
169
20c514ec
JH
170{
171 my $gimme;
172
173 sub gimme {
cb9881c1
RGS
174 my $want = wantarray();
175 if (defined $want) {
176 $gimme = $want ? 'list' : 'scalar';
177 } else {
178 $gimme = 'void';
179 }
20c514ec
JH
180 }
181
182 my @list = 0..9;
183
cb9881c1
RGS
184 undef $gimme; gimme for @list; cmp_ok($gimme, 'eq', 'void', 'gimme a V!');
185 undef $gimme; grep { gimme } @list; cmp_ok($gimme, 'eq', 'scalar', 'gimme an S!');
186 undef $gimme; map { gimme } @list; cmp_ok($gimme, 'eq', 'list', 'gimme an L!');
187}
188
189{
190 # test scalar context return
191 my @list = (7, 14, 21);
192
193 my $x = map {$_ *= 2} @list;
194 cmp_ok("@list", 'eq', "14 28 42", 'map scalar return');
195 cmp_ok($x, '==', 3, 'map scalar count');
196
197 @list = (9, 16, 25, 36);
198 $x = grep {$_ % 2} @list;
199 cmp_ok($x, '==', 2, 'grep scalar count');
200
201 my @res = grep {$_ % 2} @list;
202 cmp_ok("@res", 'eq', "9 25", 'grep extract');
20c514ec 203}
b3c0f1bd 204
e3c9a8b9 205{
93f09d7b 206 # This shouldn't loop indefinitely.
e3c9a8b9 207 my @empty = map { while (1) {} } ();
cb9881c1 208 cmp_ok("@empty", 'eq', '', 'staying alive');
e3c9a8b9 209}
f6435df3
GG
210
211{
212 my $x;
213 eval 'grep $x (1,2,3);';
214 like($@, qr/Missing comma after first argument to grep function/,
215 "proper error on variable as block. [perl #37314]");
216}
55b5114f 217
2d885586 218# [perl #78194] grep/map aliasing op return values
2d885586 219grep is(\$_, \$_, '[perl #78194] \$_ == \$_ inside grep ..., "$x"'),
a0ed822e 220 "${\''}", "${\''}";
2d885586 221map is(\$_, \$_, '[perl #78194] \$_ == \$_ inside map ..., "$x"'),
a0ed822e 222 "${\''}", "${\''}";
2d885586 223
55b5114f
FC
224# [perl #92254] freeing $_ in gremap block
225{
226 my $y;
227 grep { undef *_ } $y;
228 map { undef *_ } $y;
229}
230pass 'no double frees with grep/map { undef *_ }';
75bc488d
DM
231
232# Don't mortalise PADTMPs.
233# This failed while I was messing with leave stuff (but not in a simple
234# test, so add one). The '1;' ensures the block is wrapped in ENTER/LEAVE;
235# the stringify returns a PADTMP. DAPM.
236
237{
238 my @a = map { 1; "$_" } 1,2;
239 is("@a", "1 2", "PADTMP");
240}