| 1 | #!./perl |
| 2 | |
| 3 | # |
| 4 | # grep() and map() tests |
| 5 | # |
| 6 | |
| 7 | BEGIN { |
| 8 | chdir 't' if -d 't'; |
| 9 | require "./test.pl"; |
| 10 | set_up_inc( qw(. ../lib) ); |
| 11 | } |
| 12 | |
| 13 | plan( tests => 77 ); |
| 14 | |
| 15 | { |
| 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'); |
| 26 | } |
| 27 | |
| 28 | { |
| 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'); |
| 131 | } |
| 132 | |
| 133 | { |
| 134 | # Tests for "for" in "map" and "grep" |
| 135 | # Used to dump core, bug [perl #17771] |
| 136 | |
| 137 | my @x; |
| 138 | my $y = ''; |
| 139 | @x = map { $y .= $_ for 1..2; 1 } 3..4; |
| 140 | cmp_ok( "@x,$y",'eq',"1 1,1212", '[perl #17771] for in map 1'); |
| 141 | |
| 142 | $y = ''; |
| 143 | @x = map { $y .= $_ for 1..2; $y .= $_ } 3..4; |
| 144 | cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 2'); |
| 145 | |
| 146 | $y = ''; |
| 147 | @x = map { for (1..2) { $y .= $_ } $y .= $_ } 3..4; |
| 148 | cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 3'); |
| 149 | |
| 150 | $y = ''; |
| 151 | @x = grep { $y .= $_ for 1..2; 1 } 3..4; |
| 152 | cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 1'); |
| 153 | |
| 154 | $y = ''; |
| 155 | @x = grep { for (1..2) { $y .= $_ } 1 } 3..4; |
| 156 | cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 2'); |
| 157 | |
| 158 | # Add also a sample test from [perl #18153]. (The same bug). |
| 159 | $a = 1; map {if ($a){}} (2); |
| 160 | pass( '[perl #18153] (not dead yet)' ); # no core dump is all we need |
| 161 | } |
| 162 | |
| 163 | { |
| 164 | sub add_an_x(@){ |
| 165 | map {"${_}x"} @_; |
| 166 | }; |
| 167 | cmp_ok( join("-",add_an_x(1,2,3,4)), 'eq', "1x-2x-3x-4x", 'add-an-x'); |
| 168 | } |
| 169 | |
| 170 | { |
| 171 | my $gimme; |
| 172 | |
| 173 | sub gimme { |
| 174 | my $want = wantarray(); |
| 175 | if (defined $want) { |
| 176 | $gimme = $want ? 'list' : 'scalar'; |
| 177 | } else { |
| 178 | $gimme = 'void'; |
| 179 | } |
| 180 | } |
| 181 | |
| 182 | my @list = 0..9; |
| 183 | |
| 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'); |
| 203 | } |
| 204 | |
| 205 | { |
| 206 | # This shouldn't loop indefinitely. |
| 207 | my @empty = map { while (1) {} } (); |
| 208 | cmp_ok("@empty", 'eq', '', 'staying alive'); |
| 209 | } |
| 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 | } |
| 217 | |
| 218 | # [perl #78194] grep/map aliasing op return values |
| 219 | grep is(\$_, \$_, '[perl #78194] \$_ == \$_ inside grep ..., "$x"'), |
| 220 | "${\''}", "${\''}"; |
| 221 | map is(\$_, \$_, '[perl #78194] \$_ == \$_ inside map ..., "$x"'), |
| 222 | "${\''}", "${\''}"; |
| 223 | |
| 224 | # [perl #92254] freeing $_ in gremap block |
| 225 | { |
| 226 | my $y; |
| 227 | grep { undef *_ } $y; |
| 228 | map { undef *_ } $y; |
| 229 | } |
| 230 | pass 'no double frees with grep/map { undef *_ }'; |
| 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 | } |
| 241 | |
| 242 | |
| 243 | package FOO { |
| 244 | my $count; |
| 245 | sub DESTROY { $count++ } |
| 246 | my @a; |
| 247 | |
| 248 | # check all grep arguments are immediately released |
| 249 | |
| 250 | $count = 0; |
| 251 | @a = (bless([]), bless([]), bless([])); |
| 252 | grep 1, @a; |
| 253 | ::is ($count, 0, "grep void pre"); |
| 254 | @a = (); |
| 255 | ::is ($count, 3, "grep void post"); |
| 256 | |
| 257 | $count = 0; |
| 258 | @a = (bless([]), bless([]), bless([])); |
| 259 | my $x = grep 1, @a; |
| 260 | ::is ($count, 0, "grep scalar pre"); |
| 261 | @a = (); |
| 262 | ::is ($count, 3, "grep scalar post"); |
| 263 | |
| 264 | $count = 0; |
| 265 | @a = (bless([]), bless([]), bless([])); |
| 266 | () = grep 1, @a; |
| 267 | ::is ($count, 0, "grep list pre"); |
| 268 | @a = (); |
| 269 | ::is ($count, 3, "grep list post"); |
| 270 | |
| 271 | # check check map expression results are immediately released |
| 272 | # in void context |
| 273 | |
| 274 | $count = 1; |
| 275 | map { |
| 276 | ::is ($count, 1, "block map void $_"); |
| 277 | $count = 0; |
| 278 | bless[]; |
| 279 | } 1,2,3; |
| 280 | } |
| 281 | |
| 282 | # At one point during development, this code SEGVed on PERL_RC_STACK |
| 283 | # builds, as NULL filler pointers on the stack during a map were getting |
| 284 | # copied to the tmps stack, and the tmps stack can't handle NULL pointers. |
| 285 | # The bug only occurred in IO::Socket::SSL rather than core. It required |
| 286 | # perl doing a call_sv(.., G_EVAL) to call the sub containing the map. In |
| 287 | # the original bug this was triggered by a use/require, but here we use a |
| 288 | # BEGIN within an eval as simpler variant. |
| 289 | |
| 290 | { |
| 291 | my @res; |
| 292 | eval q{ |
| 293 | BEGIN { @res = map { $_ => eval {die} || -1 } qw( ABC XYZ); } |
| 294 | }; |
| 295 | is("@res", "ABC -1 XYZ -1", "no NULL tmps"); |
| 296 | } |