t/op/signatures.t

   1 #!perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 use warnings;
  10 use strict;
  11
  12 our $a = 123;
  13 our $z;
  14
  15 {
  16     no warnings "illegalproto";
  17     sub t000 ($a) { $a || "z" }
  18     is prototype(\&t000), "\$a", "(\$a) interpreted as protoype when not enabled";
  19     is &t000(456), 123, "(\$a) not signature when not enabled";
  20     is $a, 123;
  21 }
  22
  23 eval "#line 8 foo\nsub t004 :method (\$a) { }";
  24 like $@, qr{syntax error at foo line 8}, "error when not enabled 1";
  25
  26 eval "#line 8 foo\nsub t005 (\$) (\$a) { }";
  27 like $@, qr{syntax error at foo line 8}, "error when not enabled 2";
  28
  29
  30 use feature "signatures";
  31
  32 sub t001 { $a || "z" }
  33 is prototype(\&t001), undef;
  34 is eval("t001()"), 123;
  35 is eval("t001(456)"), 123;
  36 is eval("t001(456, 789)"), 123;
  37 is $a, 123;
  38
  39 sub _create_mismatch_regexp {
  40     my ($funcname, $got, $expected, $flexible_str) = @_;
  41
  42     my $many_few_str = ($got > $expected) ? 'many' : 'few';
  43
  44     $flexible_str //= q<>;
  45
  46     return qr/\AToo $many_few_str arguments for subroutine '$funcname' \(got $got; expected $flexible_str$expected\) at \(eval \d+\) line 1\.\n\z/;
  47 }
  48
  49 sub _create_flexible_mismatch_regexp {
  50     my ($funcname, $got, $expected) = @_;
  51
  52     my $flexible_str = ($got > $expected) ? 'at most' : 'at least';
  53     $flexible_str .= q< >;
  54
  55     return _create_mismatch_regexp($funcname, $got, $expected, $flexible_str);
  56 }
  57
  58 sub t002 () { $a || "z" }
  59 is prototype(\&t002), undef;
  60 is eval("t002()"), 123;
  61 is eval("t002(456)"), undef;
  62 like $@, _create_mismatch_regexp('main::t002', 1, 0);
  63 is eval("t002(456, 789)"), undef;
  64 like $@, _create_mismatch_regexp('main::t002', 2, 0);
  65 is $a, 123;
  66
  67 sub t003 ( ) { $a || "z" }
  68 is prototype(\&t003), undef;
  69 is eval("t003()"), 123;
  70 is eval("t003(456)"), undef;
  71 like $@, _create_mismatch_regexp('main::t003', 1, 0);
  72 is eval("t003(456, 789)"), undef;
  73 like $@, _create_mismatch_regexp('main::t003', 2, 0);
  74 is $a, 123;
  75
  76 sub t006 ($a) { $a || "z" }
  77 is prototype(\&t006), undef;
  78 is eval("t006()"), undef;
  79 like $@, _create_mismatch_regexp('main::t006', 0, 1);
  80 is eval("t006(0)"), "z";
  81 is eval("t006(456)"), 456;
  82 is eval("t006(456, 789)"), undef;
  83 like $@, _create_mismatch_regexp('main::t006', 2, 1);
  84 is eval("t006(456, 789, 987)"), undef;
  85 like $@, _create_mismatch_regexp('main::t006', 3, 1);
  86 is $a, 123;
  87
  88 sub t007 ($a, $b) { $a.$b }
  89 is prototype(\&t007), undef;
  90 is eval("t007()"), undef;
  91 like $@, _create_mismatch_regexp('main::t007', 0, 2);
  92 is eval("t007(456)"), undef;
  93 like $@, _create_mismatch_regexp('main::t007', 1, 2);
  94 is eval("t007(456, 789)"), "456789";
  95 is eval("t007(456, 789, 987)"), undef;
  96 like $@, _create_mismatch_regexp('main::t007', 3, 2);
  97 is eval("t007(456, 789, 987, 654)"), undef;
  98 like $@, _create_mismatch_regexp('main::t007', 4, 2);
  99 is $a, 123;
 100
 101 sub t008 ($a, $b, $c) { $a.$b.$c }
 102 is prototype(\&t008), undef;
 103 is eval("t008()"), undef;
 104 like $@, _create_mismatch_regexp('main::t008', 0, 3);
 105 is eval("t008(456)"), undef;
 106 like $@, _create_mismatch_regexp('main::t008', 1, 3);
 107 is eval("t008(456, 789)"), undef;
 108 like $@, _create_mismatch_regexp('main::t008', 2, 3);
 109 is eval("t008(456, 789, 987)"), "456789987";
 110 is eval("t008(456, 789, 987, 654)"), undef;
 111 like $@, _create_mismatch_regexp('main::t008', 4, 3);
 112 is $a, 123;
 113
 114 sub t009 ($abc, $def) { $abc.$def }
 115 is prototype(\&t009), undef;
 116 is eval("t009()"), undef;
 117 like $@, _create_mismatch_regexp('main::t009', 0, 2);
 118 is eval("t009(456)"), undef;
 119 like $@, _create_mismatch_regexp('main::t009', 1, 2);
 120 is eval("t009(456, 789)"), "456789";
 121 is eval("t009(456, 789, 987)"), undef;
 122 like $@, _create_mismatch_regexp('main::t009', 3, 2);
 123 is eval("t009(456, 789, 987, 654)"), undef;
 124 like $@, _create_mismatch_regexp('main::t009', 4, 2);
 125 is $a, 123;
 126
 127 sub t010 ($a, $) { $a || "z" }
 128 is prototype(\&t010), undef;
 129 is eval("t010()"), undef;
 130 like $@, _create_mismatch_regexp('main::t010', 0, 2);
 131 is eval("t010(456)"), undef;
 132 like $@, _create_mismatch_regexp('main::t010', 1, 2);
 133 is eval("t010(0, 789)"), "z";
 134 is eval("t010(456, 789)"), 456;
 135 is eval("t010(456, 789, 987)"), undef;
 136 like $@, _create_mismatch_regexp('main::t010', 3, 2);
 137 is eval("t010(456, 789, 987, 654)"), undef;
 138 like $@, _create_mismatch_regexp('main::t010', 4, 2);
 139 is $a, 123;
 140
 141 sub t011 ($, $a) { $a || "z" }
 142 is prototype(\&t011), undef;
 143 is eval("t011()"), undef;
 144 like $@, _create_mismatch_regexp('main::t011', 0, 2);
 145 is eval("t011(456)"), undef;
 146 like $@, _create_mismatch_regexp('main::t011', 1, 2);
 147 is eval("t011(456, 0)"), "z";
 148 is eval("t011(456, 789)"), 789;
 149 is eval("t011(456, 789, 987)"), undef;
 150 like $@, _create_mismatch_regexp('main::t011', 3, 2);
 151 is eval("t011(456, 789, 987, 654)"), undef;
 152 like $@, _create_mismatch_regexp('main::t011', 4, 2);
 153 is $a, 123;
 154
 155 sub t012 ($, $) { $a || "z" }
 156 is prototype(\&t012), undef;
 157 is eval("t012()"), undef;
 158 like $@, _create_mismatch_regexp('main::t012', 0, 2);
 159 is eval("t012(456)"), undef;
 160 like $@, _create_mismatch_regexp('main::t012', 1, 2);
 161 is eval("t012(0, 789)"), 123;
 162 is eval("t012(456, 789)"), 123;
 163 is eval("t012(456, 789, 987)"), undef;
 164 like $@, _create_mismatch_regexp('main::t012', 3, 2);
 165 is eval("t012(456, 789, 987, 654)"), undef;
 166 like $@, _create_mismatch_regexp('main::t012', 4, 2);
 167 is $a, 123;
 168
 169 sub t013 ($) { $a || "z" }
 170 is prototype(\&t013), undef;
 171 is eval("t013()"), undef;
 172 like $@, _create_mismatch_regexp('main::t013', 0, 1);
 173 is eval("t013(0)"), 123;
 174 is eval("t013(456)"), 123;
 175 is eval("t013(456, 789)"), undef;
 176 like $@, _create_mismatch_regexp('main::t013', 2, 1);
 177 is eval("t013(456, 789, 987)"), undef;
 178 like $@, _create_mismatch_regexp('main::t013', 3, 1);
 179 is eval("t013(456, 789, 987, 654)"), undef;
 180 like $@, _create_mismatch_regexp('main::t013', 4, 1);
 181 is $a, 123;
 182
 183 sub t014 ($a = 222) { $a // "z" }
 184 is prototype(\&t014), undef;
 185 is eval("t014()"), 222;
 186 is eval("t014(0)"), 0;
 187 is eval("t014(undef)"), "z";
 188 is eval("t014(456)"), 456;
 189 is eval("t014(456, 789)"), undef;
 190 like $@, _create_flexible_mismatch_regexp('main::t014', 2, 1);
 191 is eval("t014(456, 789, 987)"), undef;
 192 like $@, _create_flexible_mismatch_regexp('main::t014', 3, 1);
 193 is $a, 123;
 194
 195 sub t015 ($a = undef) { $a // "z" }
 196 is prototype(\&t015), undef;
 197 is eval("t015()"), "z";
 198 is eval("t015(0)"), 0;
 199 is eval("t015(undef)"), "z";
 200 is eval("t015(456)"), 456;
 201 is eval("t015(456, 789)"), undef;
 202 like $@, _create_flexible_mismatch_regexp('main::t015', 2, 1);
 203 is eval("t015(456, 789, 987)"), undef;
 204 like $@, _create_flexible_mismatch_regexp('main::t015', 3, 1);
 205 is $a, 123;
 206
 207 sub t016 ($a = do { $z++; 222 }) { $a // "z" }
 208 $z = 0;
 209 is prototype(\&t016), undef;
 210 is eval("t016()"), 222;
 211 is $z, 1;
 212 is eval("t016(0)"), 0;
 213 is eval("t016(undef)"), "z";
 214 is eval("t016(456)"), 456;
 215 is eval("t016(456, 789)"), undef;
 216 like $@, _create_flexible_mismatch_regexp('main::t016', 2, 1);
 217 is eval("t016(456, 789, 987)"), undef;
 218 like $@, _create_flexible_mismatch_regexp('main::t016', 3, 1);
 219 is $z, 1;
 220 is eval("t016()"), 222;
 221 is $z, 2;
 222 is $a, 123;
 223
 224 sub t018 { join("/", @_) }
 225 sub t017 ($p = t018 222, $a = 333) { $p // "z" }
 226 is prototype(\&t017), undef;
 227 is eval("t017()"), "222/333";
 228 is $a, 333;
 229 $a = 123;
 230 is eval("t017(0)"), 0;
 231 is eval("t017(undef)"), "z";
 232 is eval("t017(456)"), 456;
 233 is eval("t017(456, 789)"), undef;
 234 like $@, _create_flexible_mismatch_regexp('main::t017', 2, 1);
 235 is eval("t017(456, 789, 987)"), undef;
 236 like $@, _create_flexible_mismatch_regexp('main::t017', 3, 1);
 237 is $a, 123;
 238
 239 sub t019 ($p = 222, $a = 333) { "$p/$a" }
 240 is prototype(\&t019), undef;
 241 is eval("t019()"), "222/333";
 242 is eval("t019(0)"), "0/333";
 243 is eval("t019(456)"), "456/333";
 244 is eval("t019(456, 789)"), "456/789";
 245 is eval("t019(456, 789, 987)"), undef;
 246 like $@, _create_flexible_mismatch_regexp('main::t019', 3, 2);
 247 is $a, 123;
 248
 249 sub t020 :prototype($) { $_[0]."z" }
 250 sub t021 ($p = t020 222, $a = 333) { "$p/$a" }
 251 is prototype(\&t021), undef;
 252 is eval("t021()"), "222z/333";
 253 is eval("t021(0)"), "0/333";
 254 is eval("t021(456)"), "456/333";
 255 is eval("t021(456, 789)"), "456/789";
 256 is eval("t021(456, 789, 987)"), undef;
 257 like $@, _create_flexible_mismatch_regexp('main::t021', 3, 2);
 258 is $a, 123;
 259
 260 sub t022 ($p = do { $z += 10; 222 }, $a = do { $z++; 333 }) { "$p/$a" }
 261 $z = 0;
 262 is prototype(\&t022), undef;
 263 is eval("t022()"), "222/333";
 264 is $z, 11;
 265 is eval("t022(0)"), "0/333";
 266 is $z, 12;
 267 is eval("t022(456)"), "456/333";
 268 is $z, 13;
 269 is eval("t022(456, 789)"), "456/789";
 270 is eval("t022(456, 789, 987)"), undef;
 271 like $@, _create_flexible_mismatch_regexp('main::t022', 3, 2);
 272 is $z, 13;
 273 is $a, 123;
 274
 275 sub t023 ($a = sub { $_[0]."z" }) { $a->("a")."y" }
 276 is prototype(\&t023), undef;
 277 is eval("t023()"), "azy";
 278 is eval("t023(sub { \"x\".\$_[0].\"x\" })"), "xaxy";
 279 is eval("t023(sub { \"x\".\$_[0].\"x\" }, 789)"), undef;
 280 like $@, _create_flexible_mismatch_regexp('main::t023', 2, 1);
 281 is $a, 123;
 282
 283 sub t036 ($a = $a."x") { $a."y" }
 284 is prototype(\&t036), undef;
 285 is eval("t036()"), "123xy";
 286 is eval("t036(0)"), "0y";
 287 is eval("t036(456)"), "456y";
 288 is eval("t036(456, 789)"), undef;
 289 like $@, _create_flexible_mismatch_regexp('main::t036', 2, 1);
 290 is $a, 123;
 291
 292 sub t120 ($a = $_) { $a // "z" }
 293 is prototype(\&t120), undef;
 294 $_ = "___";
 295 is eval("t120()"), "___";
 296 $_ = "___";
 297 is eval("t120(undef)"), "z";
 298 $_ = "___";
 299 is eval("t120(0)"), 0;
 300 $_ = "___";
 301 is eval("t120(456)"), 456;
 302 $_ = "___";
 303 is eval("t120(456, 789)"), undef;
 304 like $@, _create_flexible_mismatch_regexp('main::t120', 2, 1);
 305 is $a, 123;
 306
 307 sub t121 ($a = caller) { $a // "z" }
 308 is prototype(\&t121), undef;
 309 is eval("t121()"), "main";
 310 is eval("t121(undef)"), "z";
 311 is eval("t121(0)"), 0;
 312 is eval("t121(456)"), 456;
 313 is eval("t121(456, 789)"), undef;
 314 like $@, _create_flexible_mismatch_regexp('main::t121', 2, 1);
 315 is eval("package T121::Z; ::t121()"), "T121::Z";
 316 is eval("package T121::Z; ::t121(undef)"), "z";
 317 is eval("package T121::Z; ::t121(0)"), 0;
 318 is eval("package T121::Z; ::t121(456)"), 456;
 319 is eval("package T121::Z; ::t121(456, 789)"), undef;
 320 like $@, _create_flexible_mismatch_regexp('main::t121', 2, 1);
 321 is $a, 123;
 322
 323 sub t129 ($a = return 222) { $a."x" }
 324 is prototype(\&t129), undef;
 325 is eval("t129()"), "222";
 326 is eval("t129(0)"), "0x";
 327 is eval("t129(456)"), "456x";
 328 is eval("t129(456, 789)"), undef;
 329 like $@, _create_flexible_mismatch_regexp('main::t129', 2, 1);
 330 is $a, 123;
 331
 332 use feature "current_sub";
 333 sub t122 ($c = 5, $r = $c > 0 ? __SUB__->($c - 1) : "") { $c.$r }
 334 is prototype(\&t122), undef;
 335 is eval("t122()"), "543210";
 336 is eval("t122(0)"), "0";
 337 is eval("t122(1)"), "10";
 338 is eval("t122(5)"), "543210";
 339 is eval("t122(5, 789)"), "5789";
 340 is eval("t122(5, 789, 987)"), undef;
 341 like $@, _create_flexible_mismatch_regexp('main::t122', 3, 2);
 342 is $a, 123;
 343
 344 sub t123 ($list = wantarray) { $list ? "list" : "scalar" }
 345 is prototype(\&t123), undef;
 346 is eval("scalar(t123())"), "scalar";
 347 is eval("(t123())[0]"), "list";
 348 is eval("scalar(t123(0))"), "scalar";
 349 is eval("(t123(0))[0]"), "scalar";
 350 is eval("scalar(t123(1))"), "list";
 351 is eval("(t123(1))[0]"), "list";
 352 is eval("t123(456, 789)"), undef;
 353 like $@, _create_flexible_mismatch_regexp('main::t123', 2, 1);
 354 is $a, 123;
 355
 356 sub t124 ($b = (local $a = $a + 1)) { "$a/$b" }
 357 is prototype(\&t124), undef;
 358 is eval("t124()"), "124/124";
 359 is $a, 123;
 360 is eval("t124(456)"), "123/456";
 361 is $a, 123;
 362 is eval("t124(456, 789)"), undef;
 363 like $@, _create_flexible_mismatch_regexp('main::t124', 2, 1);
 364 is $a, 123;
 365
 366 sub t125 ($c = (our $t125_counter)++) { $c }
 367 is prototype(\&t125), undef;
 368 is eval("t125()"), 0;
 369 is eval("t125()"), 1;
 370 is eval("t125()"), 2;
 371 is eval("t125(456)"), 456;
 372 is eval("t125(789)"), 789;
 373 is eval("t125()"), 3;
 374 is eval("t125()"), 4;
 375 is eval("t125(456, 789)"), undef;
 376 like $@, _create_flexible_mismatch_regexp('main::t125', 2, 1);
 377 is $a, 123;
 378
 379 use feature "state";
 380 sub t126 ($c = (state $s = $z++)) { $c }
 381 is prototype(\&t126), undef;
 382 $z = 222;
 383 is eval("t126(456)"), 456;
 384 is $z, 222;
 385 is eval("t126()"), 222;
 386 is $z, 223;
 387 is eval("t126(456)"), 456;
 388 is $z, 223;
 389 is eval("t126()"), 222;
 390 is $z, 223;
 391 is eval("t126(456, 789)"), undef;
 392 like $@, _create_flexible_mismatch_regexp('main::t126', 2, 1);
 393 is $z, 223;
 394 is $a, 123;
 395
 396 sub t127 ($c = do { state $s = $z++; $s++ }) { $c }
 397 is prototype(\&t127), undef;
 398 $z = 222;
 399 is eval("t127(456)"), 456;
 400 is $z, 222;
 401 is eval("t127()"), 222;
 402 is $z, 223;
 403 is eval("t127()"), 223;
 404 is eval("t127()"), 224;
 405 is $z, 223;
 406 is eval("t127(456)"), 456;
 407 is eval("t127(789)"), 789;
 408 is eval("t127()"), 225;
 409 is eval("t127()"), 226;
 410 is eval("t127(456, 789)"), undef;
 411 like $@, _create_flexible_mismatch_regexp('main::t127', 2, 1);
 412 is $z, 223;
 413 is $a, 123;
 414
 415 sub t037 ($a = 222, $b = $a."x") { "$a/$b" }
 416 is prototype(\&t037), undef;
 417 is eval("t037()"), "222/222x";
 418 is eval("t037(0)"), "0/0x";
 419 is eval("t037(456)"), "456/456x";
 420 is eval("t037(456, 789)"), "456/789";
 421 is eval("t037(456, 789, 987)"), undef;
 422 like $@, _create_flexible_mismatch_regexp('main::t037', 3, 2);
 423 is $a, 123;
 424
 425 sub t128 ($a = 222, $b = ($a = 333)) { "$a/$b" }
 426 is prototype(\&t128), undef;
 427 is eval("t128()"), "333/333";
 428 is eval("t128(0)"), "333/333";
 429 is eval("t128(456)"), "333/333";
 430 is eval("t128(456, 789)"), "456/789";
 431 is eval("t128(456, 789, 987)"), undef;
 432 like $@, _create_flexible_mismatch_regexp('main::t128', 3, 2);
 433 is $a, 123;
 434
 435 sub t130 { join(",", @_).";".scalar(@_) }
 436 {
 437     no warnings 'experimental::args_array_with_signatures';
 438     sub t131 ($a = 222, $b = goto &t130) { "$a/$b" }
 439 }
 440 is prototype(\&t131), undef;
 441 is eval("t131()"), ";0";
 442 is eval("t131(0)"), "0;1";
 443 is eval("t131(456)"), "456;1";
 444 is eval("t131(456, 789)"), "456/789";
 445 is eval("t131(456, 789, 987)"), undef;
 446 like $@, _create_flexible_mismatch_regexp('main::t131', 3, 2);
 447 is $a, 123;
 448
 449 eval "#line 8 foo\nsub t024 (\$a =) { }";
 450 is $@,
 451     qq{Optional parameter lacks default expression at foo line 8, near "=) "\n};
 452
 453 sub t025 ($ = undef) { $a // "z" }
 454 is prototype(\&t025), undef;
 455 is eval("t025()"), 123;
 456 is eval("t025(0)"), 123;
 457 is eval("t025(456)"), 123;
 458 is eval("t025(456, 789)"), undef;
 459 like $@, _create_flexible_mismatch_regexp('main::t025', 2, 1);
 460 is eval("t025(456, 789, 987)"), undef;
 461 like $@, _create_flexible_mismatch_regexp('main::t025', 3, 1);
 462 is eval("t025(456, 789, 987, 654)"), undef;
 463 like $@, _create_flexible_mismatch_regexp('main::t025', 4, 1);
 464 is $a, 123;
 465
 466 sub t026 ($ = 222) { $a // "z" }
 467 is prototype(\&t026), undef;
 468 is eval("t026()"), 123;
 469 is eval("t026(0)"), 123;
 470 is eval("t026(456)"), 123;
 471 is eval("t026(456, 789)"), undef;
 472 like $@, _create_flexible_mismatch_regexp('main::t026', 2, 1);
 473 is eval("t026(456, 789, 987)"), undef;
 474 like $@, _create_flexible_mismatch_regexp('main::t026', 3, 1);
 475 is eval("t026(456, 789, 987, 654)"), undef;
 476 like $@, _create_flexible_mismatch_regexp('main::t026', 4, 1);
 477 is $a, 123;
 478
 479 sub t032 ($ = do { $z++; 222 }) { $a // "z" }
 480 $z = 0;
 481 is prototype(\&t032), undef;
 482 is eval("t032()"), 123;
 483 is $z, 1;
 484 is eval("t032(0)"), 123;
 485 is eval("t032(456)"), 123;
 486 is eval("t032(456, 789)"), undef;
 487 like $@, _create_flexible_mismatch_regexp('main::t032', 2, 1);
 488 is eval("t032(456, 789, 987)"), undef;
 489 like $@, _create_flexible_mismatch_regexp('main::t032', 3, 1);
 490 is eval("t032(456, 789, 987, 654)"), undef;
 491 like $@, _create_flexible_mismatch_regexp('main::t032', 4, 1);
 492 is $z, 1;
 493 is $a, 123;
 494
 495 sub t027 ($ =) { $a // "z" }
 496 is prototype(\&t027), undef;
 497 is eval("t027()"), 123;
 498 is eval("t027(0)"), 123;
 499 is eval("t027(456)"), 123;
 500 is eval("t027(456, 789)"), undef;
 501 like $@, _create_flexible_mismatch_regexp('main::t027', 2, 1);
 502 is eval("t027(456, 789, 987)"), undef;
 503 like $@, _create_flexible_mismatch_regexp('main::t027', 3, 1);
 504 is eval("t027(456, 789, 987, 654)"), undef;
 505 like $@, _create_flexible_mismatch_regexp('main::t027', 4, 1);
 506 is $a, 123;
 507
 508 sub t119 ($ =, $a = 333) { $a // "z" }
 509 is prototype(\&t119), undef;
 510 is eval("t119()"), 333;
 511 is eval("t119(0)"), 333;
 512 is eval("t119(456)"), 333;
 513 is eval("t119(456, 789)"), 789;
 514 is eval("t119(456, 789, 987)"), undef;
 515 like $@, _create_flexible_mismatch_regexp('main::t119', 3, 2);
 516 is eval("t119(456, 789, 987, 654)"), undef;
 517 like $@, _create_flexible_mismatch_regexp('main::t119', 4, 2);
 518 is $a, 123;
 519
 520 sub t028 ($a, $b = 333) { "$a/$b" }
 521 is prototype(\&t028), undef;
 522 is eval("t028()"), undef;
 523 like $@, _create_flexible_mismatch_regexp('main::t028', 0, 1);
 524 is eval("t028(0)"), "0/333";
 525 is eval("t028(456)"), "456/333";
 526 is eval("t028(456, 789)"), "456/789";
 527 is eval("t028(456, 789, 987)"), undef;
 528 like $@, _create_flexible_mismatch_regexp('main::t028', 3, 2);
 529 is $a, 123;
 530
 531 sub t045 ($a, $ = 333) { "$a/" }
 532 is prototype(\&t045), undef;
 533 is eval("t045()"), undef;
 534 like $@, _create_flexible_mismatch_regexp('main::t045', 0, 1);
 535 is eval("t045(0)"), "0/";
 536 is eval("t045(456)"), "456/";
 537 is eval("t045(456, 789)"), "456/";
 538 is eval("t045(456, 789, 987)"), undef;
 539 like $@, _create_flexible_mismatch_regexp('main::t045', 3, 2);
 540 is $a, 123;
 541
 542 sub t046 ($, $b = 333) { "$a/$b" }
 543 is prototype(\&t046), undef;
 544 is eval("t046()"), undef;
 545 like $@, _create_flexible_mismatch_regexp('main::t046', 0, 1);
 546 is eval("t046(0)"), "123/333";
 547 is eval("t046(456)"), "123/333";
 548 is eval("t046(456, 789)"), "123/789";
 549 is eval("t046(456, 789, 987)"), undef;
 550 like $@, _create_flexible_mismatch_regexp('main::t046', 3, 2);
 551 is $a, 123;
 552
 553 sub t047 ($, $ = 333) { "$a/" }
 554 is prototype(\&t047), undef;
 555 is eval("t047()"), undef;
 556 like $@, _create_flexible_mismatch_regexp('main::t047', 0, 1);
 557 is eval("t047(0)"), "123/";
 558 is eval("t047(456)"), "123/";
 559 is eval("t047(456, 789)"), "123/";
 560 is eval("t047(456, 789, 987)"), undef;
 561 like $@, _create_flexible_mismatch_regexp('main::t047', 3, 2);
 562 is $a, 123;
 563
 564 sub t029 ($a, $b, $c = 222, $d = 333) { "$a/$b/$c/$d" }
 565 is prototype(\&t029), undef;
 566 is eval("t029()"), undef;
 567 like $@, _create_flexible_mismatch_regexp('main::t029', 0, 2);
 568 is eval("t029(0)"), undef;
 569 like $@, _create_flexible_mismatch_regexp('main::t029', 1, 2);
 570 is eval("t029(456)"), undef;
 571 like $@, _create_flexible_mismatch_regexp('main::t029', 1, 2);
 572 is eval("t029(456, 789)"), "456/789/222/333";
 573 is eval("t029(456, 789, 987)"), "456/789/987/333";
 574 is eval("t029(456, 789, 987, 654)"), "456/789/987/654";
 575 is eval("t029(456, 789, 987, 654, 321)"), undef;
 576 like $@, _create_flexible_mismatch_regexp('main::t029', 5, 4);
 577 is eval("t029(456, 789, 987, 654, 321, 111)"), undef;
 578 like $@, _create_flexible_mismatch_regexp('main::t029', 6, 4);
 579 is $a, 123;
 580
 581 sub t038 ($a, $b = $a."x") { "$a/$b" }
 582 is prototype(\&t038), undef;
 583 is eval("t038()"), undef;
 584 like $@, _create_flexible_mismatch_regexp('main::t038', 0, 1);
 585 is eval("t038(0)"), "0/0x";
 586 is eval("t038(456)"), "456/456x";
 587 is eval("t038(456, 789)"), "456/789";
 588 is eval("t038(456, 789, 987)"), undef;
 589 like $@, _create_flexible_mismatch_regexp('main::t038', 3, 2);
 590 is $a, 123;
 591
 592 eval "#line 8 foo\nsub t030 (\$a = 222, \$b) { }";
 593 is $@, qq{Mandatory parameter follows optional parameter at foo line 8, near "\$b) "\n};
 594
 595 eval "#line 8 foo\nsub t031 (\$a = 222, \$b = 333, \$c, \$d) { }";
 596 is $@, <<EOF;
 597 Mandatory parameter follows optional parameter at foo line 8, near "\$c,"
 598 Mandatory parameter follows optional parameter at foo line 8, near "\$d) "
 599 EOF
 600
 601 sub t206 ($x, $y //= 3) { return $x + $y }
 602 is eval("t206(5,4)"),     9, '//= present';
 603 is eval("t206(5)"),       8, '//= absent';
 604 is eval("t206(4,undef)"), 7, '//= undef';
 605 is eval("t206(4,0)"),     4, '//= zero';
 606
 607 sub t207 ($x, $y ||= 3) { return $x + $y }
 608 is eval("t207(5,4)"),     9, '||= present';
 609 is eval("t207(5)"),       8, '||= absent';
 610 is eval("t207(4,undef)"), 7, '||= undef';
 611 is eval("t207(4,0)"),     7, '||= zero';
 612
 613 sub t034 (@abc) { join("/", @abc).";".scalar(@abc) }
 614 is prototype(\&t034), undef;
 615 is eval("t034()"), ";0";
 616 is eval("t034(0)"), "0;1";
 617 is eval("t034(456)"), "456;1";
 618 is eval("t034(456, 789)"), "456/789;2";
 619 is eval("t034(456, 789, 987)"), "456/789/987;3";
 620 is eval("t034(456, 789, 987, 654)"), "456/789/987/654;4";
 621 is eval("t034(456, 789, 987, 654, 321)"), "456/789/987/654/321;5";
 622 is eval("t034(456, 789, 987, 654, 321, 111)"), "456/789/987/654/321/111;6";
 623 is $a, 123;
 624
 625 eval "#line 8 foo\nsub t136 (\@abc = 222) { }";
 626 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
 627
 628 eval "#line 8 foo\nsub t137 (\@abc =) { }";
 629 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
 630
 631 sub t035 (@) { $a }
 632 is prototype(\&t035), undef;
 633 is eval("t035()"), 123;
 634 is eval("t035(0)"), 123;
 635 is eval("t035(456)"), 123;
 636 is eval("t035(456, 789)"), 123;
 637 is eval("t035(456, 789, 987)"), 123;
 638 is eval("t035(456, 789, 987, 654)"), 123;
 639 is eval("t035(456, 789, 987, 654, 321)"), 123;
 640 is eval("t035(456, 789, 987, 654, 321, 111)"), 123;
 641 is $a, 123;
 642
 643 eval "#line 8 foo\nsub t138 (\@ = 222) { }";
 644 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
 645
 646 eval "#line 8 foo\nsub t139 (\@ =) { }";
 647 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
 648
 649 sub t039 (%abc) { join("/", map { $_."=".$abc{$_} } sort keys %abc) }
 650 is prototype(\&t039), undef;
 651 is eval("t039()"), "";
 652 is eval("t039(0)"), undef;
 653 like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
 654 is eval("t039(456)"), undef;
 655 like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
 656 is eval("t039(456, 789)"), "456=789";
 657 is eval("t039(456, 789, 987)"), undef;
 658 like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
 659 is eval("t039(456, 789, 987, 654)"), "456=789/987=654";
 660 is eval("t039(456, 789, 987, 654, 321)"), undef;
 661 like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
 662 is eval("t039(456, 789, 987, 654, 321, 111)"), "321=111/456=789/987=654";
 663 is $a, 123;
 664
 665 eval "#line 8 foo\nsub t140 (\%abc = 222) { }";
 666 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
 667
 668 eval "#line 8 foo\nsub t141 (\%abc =) { }";
 669 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
 670
 671 sub t040 (%) { $a }
 672 is prototype(\&t040), undef;
 673 is eval("t040()"), 123;
 674 is eval("t040(0)"), undef;
 675 like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
 676 is eval("t040(456)"), undef;
 677 like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
 678 is eval("t040(456, 789)"), 123;
 679 is eval("t040(456, 789, 987)"), undef;
 680 like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
 681 is eval("t040(456, 789, 987, 654)"), 123;
 682 is eval("t040(456, 789, 987, 654, 321)"), undef;
 683 like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
 684 is eval("t040(456, 789, 987, 654, 321, 111)"), 123;
 685 is $a, 123;
 686
 687 eval "#line 8 foo\nsub t142 (\% = 222) { }";
 688 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
 689
 690 eval "#line 8 foo\nsub t143 (\% =) { }";
 691 is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
 692
 693 sub t041 ($a, @b) { $a.";".join("/", @b) }
 694 is prototype(\&t041), undef;
 695 is eval("t041()"), undef;
 696 like $@, _create_flexible_mismatch_regexp('main::t041', 0, 1);
 697 is eval("t041(0)"), "0;";
 698 is eval("t041(456)"), "456;";
 699 is eval("t041(456, 789)"), "456;789";
 700 is eval("t041(456, 789, 987)"), "456;789/987";
 701 is eval("t041(456, 789, 987, 654)"), "456;789/987/654";
 702 is eval("t041(456, 789, 987, 654, 321)"), "456;789/987/654/321";
 703 is eval("t041(456, 789, 987, 654, 321, 111)"), "456;789/987/654/321/111";
 704 is $a, 123;
 705
 706 sub t042 ($a, @) { $a.";" }
 707 is prototype(\&t042), undef;
 708 is eval("t042()"), undef;
 709 like $@, _create_flexible_mismatch_regexp('main::t042', 0, 1);
 710 is eval("t042(0)"), "0;";
 711 is eval("t042(456)"), "456;";
 712 is eval("t042(456, 789)"), "456;";
 713 is eval("t042(456, 789, 987)"), "456;";
 714 is eval("t042(456, 789, 987, 654)"), "456;";
 715 is eval("t042(456, 789, 987, 654, 321)"), "456;";
 716 is eval("t042(456, 789, 987, 654, 321, 111)"), "456;";
 717 is $a, 123;
 718
 719 sub t043 ($, @b) { $a.";".join("/", @b) }
 720 is prototype(\&t043), undef;
 721 is eval("t043()"), undef;
 722 like $@, _create_flexible_mismatch_regexp('main::t043', 0, 1);
 723 is eval("t043(0)"), "123;";
 724 is eval("t043(456)"), "123;";
 725 is eval("t043(456, 789)"), "123;789";
 726 is eval("t043(456, 789, 987)"), "123;789/987";
 727 is eval("t043(456, 789, 987, 654)"), "123;789/987/654";
 728 is eval("t043(456, 789, 987, 654, 321)"), "123;789/987/654/321";
 729 is eval("t043(456, 789, 987, 654, 321, 111)"), "123;789/987/654/321/111";
 730 is $a, 123;
 731
 732 sub t044 ($, @) { $a.";" }
 733 is prototype(\&t044), undef;
 734 is eval("t044()"), undef;
 735 like $@, _create_flexible_mismatch_regexp('main::t044', 0, 1);
 736 is eval("t044(0)"), "123;";
 737 is eval("t044(456)"), "123;";
 738 is eval("t044(456, 789)"), "123;";
 739 is eval("t044(456, 789, 987)"), "123;";
 740 is eval("t044(456, 789, 987, 654)"), "123;";
 741 is eval("t044(456, 789, 987, 654, 321)"), "123;";
 742 is eval("t044(456, 789, 987, 654, 321, 111)"), "123;";
 743 is $a, 123;
 744
 745 sub t049 ($a, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) }
 746 is prototype(\&t049), undef;
 747 is eval("t049()"), undef;
 748 like $@, _create_flexible_mismatch_regexp('main::t049', 0, 1);
 749 is eval("t049(222)"), "222;";
 750 is eval("t049(222, 456)"), undef;
 751 like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#;
 752 is eval("t049(222, 456, 789)"), "222;456=789";
 753 is eval("t049(222, 456, 789, 987)"), undef;
 754 like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#;
 755 is eval("t049(222, 456, 789, 987, 654)"), "222;456=789/987=654";
 756 is eval("t049(222, 456, 789, 987, 654, 321)"), undef;
 757 like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#;
 758 is eval("t049(222, 456, 789, 987, 654, 321, 111)"),
 759     "222;321=111/456=789/987=654";
 760 is $a, 123;
 761
 762 sub t051 ($a, $b, $c, @d) { "$a;$b;$c;".join("/", @d).";".scalar(@d) }
 763 is prototype(\&t051), undef;
 764 is eval("t051()"), undef;
 765 like $@, _create_flexible_mismatch_regexp('main::t051', 0, 3);
 766 is eval("t051(456)"), undef;
 767 like $@, _create_flexible_mismatch_regexp('main::t051', 1, 3);
 768 is eval("t051(456, 789)"), undef;
 769 like $@, _create_flexible_mismatch_regexp('main::t051', 2, 3);
 770 is eval("t051(456, 789, 987)"), "456;789;987;;0";
 771 is eval("t051(456, 789, 987, 654)"), "456;789;987;654;1";
 772 is eval("t051(456, 789, 987, 654, 321)"), "456;789;987;654/321;2";
 773 is eval("t051(456, 789, 987, 654, 321, 111)"), "456;789;987;654/321/111;3";
 774 is $a, 123;
 775
 776 sub t052 ($a, $b, %c) { "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c) }
 777 is prototype(\&t052), undef;
 778 is eval("t052()"), undef;
 779 like $@, _create_flexible_mismatch_regexp('main::t052', 0, 2);
 780 is eval("t052(222)"), undef;
 781 like $@, _create_flexible_mismatch_regexp('main::t052', 1, 2);
 782 is eval("t052(222, 333)"), "222;333;";
 783 is eval("t052(222, 333, 456)"), undef;
 784 like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#;
 785 is eval("t052(222, 333, 456, 789)"), "222;333;456=789";
 786 is eval("t052(222, 333, 456, 789, 987)"), undef;
 787 like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#;
 788 is eval("t052(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654";
 789 is eval("t052(222, 333, 456, 789, 987, 654, 321)"), undef;
 790 like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#;
 791 is eval("t052(222, 333, 456, 789, 987, 654, 321, 111)"),
 792     "222;333;321=111/456=789/987=654";
 793 is $a, 123;
 794
 795 sub t053 ($a, $b, $c, %d) {
 796     "$a;$b;$c;".join("/", map { $_."=".$d{$_} } sort keys %d)
 797 }
 798 is prototype(\&t053), undef;
 799 is eval("t053()"), undef;
 800 like $@, _create_flexible_mismatch_regexp('main::t053', 0, 3);
 801 is eval("t053(222)"), undef;
 802 like $@, _create_flexible_mismatch_regexp('main::t053', 1, 3);
 803 is eval("t053(222, 333)"), undef;
 804 like $@, _create_flexible_mismatch_regexp('main::t053', 2, 3);
 805 is eval("t053(222, 333, 444)"), "222;333;444;";
 806 is eval("t053(222, 333, 444, 456)"), undef;
 807 like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#;
 808 is eval("t053(222, 333, 444, 456, 789)"), "222;333;444;456=789";
 809 is eval("t053(222, 333, 444, 456, 789, 987)"), undef;
 810 like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#;
 811 is eval("t053(222, 333, 444, 456, 789, 987, 654)"),
 812     "222;333;444;456=789/987=654";
 813 is eval("t053(222, 333, 444, 456, 789, 987, 654, 321)"), undef;
 814 like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#;
 815 is eval("t053(222, 333, 444, 456, 789, 987, 654, 321, 111)"),
 816     "222;333;444;321=111/456=789/987=654";
 817 is $a, 123;
 818
 819 sub t048 ($a = 222, @b) { $a.";".join("/", @b).";".scalar(@b) }
 820 is prototype(\&t048), undef;
 821 is eval("t048()"), "222;;0";
 822 is eval("t048(0)"), "0;;0";
 823 is eval("t048(456)"), "456;;0";
 824 is eval("t048(456, 789)"), "456;789;1";
 825 is eval("t048(456, 789, 987)"), "456;789/987;2";
 826 is eval("t048(456, 789, 987, 654)"), "456;789/987/654;3";
 827 is eval("t048(456, 789, 987, 654, 321)"), "456;789/987/654/321;4";
 828 is eval("t048(456, 789, 987, 654, 321, 111)"), "456;789/987/654/321/111;5";
 829 is $a, 123;
 830
 831 sub t054 ($a = 222, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) }
 832 is prototype(\&t054), undef;
 833 is eval("t054()"), "222;333;;0";
 834 is eval("t054(456)"), "456;333;;0";
 835 is eval("t054(456, 789)"), "456;789;;0";
 836 is eval("t054(456, 789, 987)"), "456;789;987;1";
 837 is eval("t054(456, 789, 987, 654)"), "456;789;987/654;2";
 838 is eval("t054(456, 789, 987, 654, 321)"), "456;789;987/654/321;3";
 839 is eval("t054(456, 789, 987, 654, 321, 111)"), "456;789;987/654/321/111;4";
 840 is $a, 123;
 841
 842 sub t055 ($a = 222, $b = 333, $c = 444, @d) {
 843     "$a;$b;$c;".join("/", @d).";".scalar(@d)
 844 }
 845 is prototype(\&t055), undef;
 846 is eval("t055()"), "222;333;444;;0";
 847 is eval("t055(456)"), "456;333;444;;0";
 848 is eval("t055(456, 789)"), "456;789;444;;0";
 849 is eval("t055(456, 789, 987)"), "456;789;987;;0";
 850 is eval("t055(456, 789, 987, 654)"), "456;789;987;654;1";
 851 is eval("t055(456, 789, 987, 654, 321)"), "456;789;987;654/321;2";
 852 is eval("t055(456, 789, 987, 654, 321, 111)"), "456;789;987;654/321/111;3";
 853 is $a, 123;
 854
 855 sub t050 ($a = 211, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) }
 856 is prototype(\&t050), undef;
 857 is eval("t050()"), "211;";
 858 is eval("t050(222)"), "222;";
 859 is eval("t050(222, 456)"), undef;
 860 like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#;
 861 is eval("t050(222, 456, 789)"), "222;456=789";
 862 is eval("t050(222, 456, 789, 987)"), undef;
 863 like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#;
 864 is eval("t050(222, 456, 789, 987, 654)"), "222;456=789/987=654";
 865 is eval("t050(222, 456, 789, 987, 654, 321)"), undef;
 866 like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#;
 867 is eval("t050(222, 456, 789, 987, 654, 321, 111)"),
 868     "222;321=111/456=789/987=654";
 869 is $a, 123;
 870
 871 sub t056 ($a = 211, $b = 311, %c) {
 872     "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c)
 873 }
 874 is prototype(\&t056), undef;
 875 is eval("t056()"), "211;311;";
 876 is eval("t056(222)"), "222;311;";
 877 is eval("t056(222, 333)"), "222;333;";
 878 is eval("t056(222, 333, 456)"), undef;
 879 like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#;
 880 is eval("t056(222, 333, 456, 789)"), "222;333;456=789";
 881 is eval("t056(222, 333, 456, 789, 987)"), undef;
 882 like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#;
 883 is eval("t056(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654";
 884 is eval("t056(222, 333, 456, 789, 987, 654, 321)"), undef;
 885 like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#;
 886 is eval("t056(222, 333, 456, 789, 987, 654, 321, 111)"),
 887     "222;333;321=111/456=789/987=654";
 888 is $a, 123;
 889
 890 sub t057 ($a = 211, $b = 311, $c = 411, %d) {
 891     "$a;$b;$c;".join("/", map { $_."=".$d{$_} } sort keys %d)
 892 }
 893 is prototype(\&t057), undef;
 894 is eval("t057()"), "211;311;411;";
 895 is eval("t057(222)"), "222;311;411;";
 896 is eval("t057(222, 333)"), "222;333;411;";
 897 is eval("t057(222, 333, 444)"), "222;333;444;";
 898 is eval("t057(222, 333, 444, 456)"), undef;
 899 like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#;
 900 is eval("t057(222, 333, 444, 456, 789)"), "222;333;444;456=789";
 901 is eval("t057(222, 333, 444, 456, 789, 987)"), undef;
 902 like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#;
 903 is eval("t057(222, 333, 444, 456, 789, 987, 654)"),
 904     "222;333;444;456=789/987=654";
 905 is eval("t057(222, 333, 444, 456, 789, 987, 654, 321)"), undef;
 906 like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#;
 907 is eval("t057(222, 333, 444, 456, 789, 987, 654, 321, 111)"),
 908     "222;333;444;321=111/456=789/987=654";
 909 is $a, 123;
 910
 911 sub t058 ($a, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) }
 912 is prototype(\&t058), undef;
 913 is eval("t058()"), undef;
 914 like $@, _create_flexible_mismatch_regexp('main::t058', 0, 1);
 915 is eval("t058(456)"), "456;333;;0";
 916 is eval("t058(456, 789)"), "456;789;;0";
 917 is eval("t058(456, 789, 987)"), "456;789;987;1";
 918 is eval("t058(456, 789, 987, 654)"), "456;789;987/654;2";
 919 is eval("t058(456, 789, 987, 654, 321)"), "456;789;987/654/321;3";
 920 is eval("t058(456, 789, 987, 654, 321, 111)"), "456;789;987/654/321/111;4";
 921 is $a, 123;
 922
 923 eval "#line 8 foo\nsub t059 (\@a, \$b) { }";
 924 is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
 925
 926 eval "#line 8 foo\nsub t060 (\@a, \$b = 222) { }";
 927 is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
 928
 929 eval "#line 8 foo\nsub t061 (\@a, \@b) { }";
 930 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@b) "\n};
 931
 932 eval "#line 8 foo\nsub t062 (\@a, \%b) { }";
 933 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "%b) "\n};
 934
 935 eval "#line 8 foo\nsub t063 (\@, \$b) { }";
 936 is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
 937
 938 eval "#line 8 foo\nsub t064 (\@, \$b = 222) { }";
 939 is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
 940
 941 eval "#line 8 foo\nsub t065 (\@, \@b) { }";
 942 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@b) "\n};
 943
 944 eval "#line 8 foo\nsub t066 (\@, \%b) { }";
 945 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "%b) "\n};
 946
 947 eval "#line 8 foo\nsub t067 (\@a, \$) { }";
 948 is $@, qq{Slurpy parameter not last at foo line 8, near "\$) "\n};
 949
 950 eval "#line 8 foo\nsub t068 (\@a, \$ = 222) { }";
 951 is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
 952
 953 eval "#line 8 foo\nsub t069 (\@a, \@) { }";
 954 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@) "\n};
 955
 956 eval "#line 8 foo\nsub t070 (\@a, \%) { }";
 957 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\%) "\n};
 958
 959 eval "#line 8 foo\nsub t071 (\@, \$) { }";
 960 is $@, qq{Slurpy parameter not last at foo line 8, near "\$) "\n};
 961
 962 eval "#line 8 foo\nsub t072 (\@, \$ = 222) { }";
 963 is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
 964
 965 eval "#line 8 foo\nsub t073 (\@, \@) { }";
 966 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@) "\n};
 967
 968 eval "#line 8 foo\nsub t074 (\@, \%) { }";
 969 is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\%) "\n};
 970
 971 eval "#line 8 foo\nsub t075 (\%a, \$b) { }";
 972 is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
 973
 974 eval "#line 8 foo\nsub t076 (\%, \$b) { }";
 975 is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
 976
 977 eval "#line 8 foo\nsub t077 (\$a, \@b, \$c) { }";
 978 is $@, qq{Slurpy parameter not last at foo line 8, near "\$c) "\n};
 979
 980 eval "#line 8 foo\nsub t078 (\$a, \%b, \$c) { }";
 981 is $@, qq{Slurpy parameter not last at foo line 8, near "\$c) "\n};
 982
 983 eval "#line 8 foo\nsub t079 (\$a, \@b, \$c, \$d) { }";
 984 is $@, <<EOF;
 985 Slurpy parameter not last at foo line 8, near "\$c,"
 986 Slurpy parameter not last at foo line 8, near "\$d) "
 987 EOF
 988
 989 sub t080 ($a,,, $b) { $a.$b }
 990 is prototype(\&t080), undef;
 991 is eval("t080()"), undef;
 992 like $@, _create_mismatch_regexp('main::t080', 0, 2);
 993 is eval("t080(456)"), undef;
 994 like $@, _create_mismatch_regexp('main::t080', 1, 2);
 995 is eval("t080(456, 789)"), "456789";
 996 is eval("t080(456, 789, 987)"), undef;
 997 like $@, _create_mismatch_regexp('main::t080', 3, 2);
 998 is eval("t080(456, 789, 987, 654)"), undef;
 999 like $@, _create_mismatch_regexp('main::t080', 4, 2);
1000 is $a, 123;
1001
1002 sub t081 ($a, $b,,) { $a.$b }
1003 is prototype(\&t081), undef;
1004 is eval("t081()"), undef;
1005 like $@, _create_mismatch_regexp('main::t081', 0, 2);
1006 is eval("t081(456)"), undef;
1007 like $@, _create_mismatch_regexp('main::t081', 1, 2);
1008 is eval("t081(456, 789)"), "456789";
1009 is eval("t081(456, 789, 987)"), undef;
1010 like $@, _create_mismatch_regexp('main::t081', 3, 2);
1011 is eval("t081(456, 789, 987, 654)"), undef;
1012 like $@, _create_mismatch_regexp('main::t081', 4, 2);
1013 is $a, 123;
1014
1015 eval "#line 8 foo\nsub t082 (, \$a) { }";
1016 is $@, qq{syntax error at foo line 8, near "(,"\nExecution of foo aborted due to compilation errors.\n};
1017
1018 eval "#line 8 foo\nsub t083 (,) { }";
1019 is $@, qq{syntax error at foo line 8, near "(,"\nExecution of foo aborted due to compilation errors.\n};
1020
1021 sub t084($a,$b){ $a.$b }
1022 is prototype(\&t084), undef;
1023 is eval("t084()"), undef;
1024 like $@, _create_mismatch_regexp('main::t084', 0, 2);
1025 is eval("t084(456)"), undef;
1026 like $@, _create_mismatch_regexp('main::t084', 1, 2);
1027 is eval("t084(456, 789)"), "456789";
1028 is eval("t084(456, 789, 987)"), undef;
1029 like $@, _create_mismatch_regexp('main::t084', 3, 2);
1030 is eval("t084(456, 789, 987, 654)"), undef;
1031 like $@, _create_mismatch_regexp('main::t084', 4, 2);
1032 is $a, 123;
1033
1034 sub t085
1035     (
1036     $
1037     a
1038     ,
1039     ,
1040     $
1041     b
1042     =
1043     333
1044     ,
1045     ,
1046     )
1047     { $a.$b }
1048 is prototype(\&t085), undef;
1049 is eval("t085()"), undef;
1050 like $@, _create_flexible_mismatch_regexp('main::t085', 0, 1);
1051 is eval("t085(456)"), "456333";
1052 is eval("t085(456, 789)"), "456789";
1053 is eval("t085(456, 789, 987)"), undef;
1054 like $@, _create_flexible_mismatch_regexp('main::t085', 3, 2);
1055 is eval("t085(456, 789, 987, 654)"), undef;
1056 like $@, _create_flexible_mismatch_regexp('main::t085', 4, 2);
1057 is $a, 123;
1058
1059 sub t086
1060     ( #foo)))
1061     $ #foo)))
1062     a #foo)))
1063     , #foo)))
1064     , #foo)))
1065     $ #foo)))
1066     b #foo)))
1067     = #foo)))
1068     333 #foo)))
1069     , #foo)))
1070     , #foo)))
1071     ) #foo)))
1072     { $a.$b }
1073 is prototype(\&t086), undef;
1074 is eval("t086()"), undef;
1075 like $@, _create_flexible_mismatch_regexp('main::t086', 0, 1);
1076 is eval("t086(456)"), "456333";
1077 is eval("t086(456, 789)"), "456789";
1078 is eval("t086(456, 789, 987)"), undef;
1079 like $@, _create_flexible_mismatch_regexp('main::t086', 3, 2);
1080 is eval("t086(456, 789, 987, 654)"), undef;
1081 like $@, _create_flexible_mismatch_regexp('main::t086', 4, 2);
1082 is $a, 123;
1083
1084 sub t087
1085     (#foo)))
1086     $ #foo)))
1087     a#foo)))
1088     ,#foo)))
1089     ,#foo)))
1090     $ #foo)))
1091     b#foo)))
1092     =#foo)))
1093     333#foo)))
1094     ,#foo)))
1095     ,#foo)))
1096     )#foo)))
1097     { $a.$b }
1098 is prototype(\&t087), undef;
1099 is eval("t087()"), undef;
1100 like $@, _create_flexible_mismatch_regexp('main::t087', 0, 1);
1101 is eval("t087(456)"), "456333";
1102 is eval("t087(456, 789)"), "456789";
1103 is eval("t087(456, 789, 987)"), undef;
1104 like $@, _create_flexible_mismatch_regexp('main::t087', 3, 2);
1105 is eval("t087(456, 789, 987, 654)"), undef;
1106 like $@, _create_flexible_mismatch_regexp('main::t087', 4, 2);
1107 is $a, 123;
1108
1109 eval "#line 8 foo\nsub t088 (\$ #foo\na) { }";
1110 is $@, "";
1111
1112
1113 eval "#line 8 foo\nsub t089 (\$#foo\na) { }";
1114 like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(\$"\n};
1115
1116 eval "#line 8 foo\nsub t090 (\@ #foo\na) { }";
1117 is $@, "";
1118
1119 eval "#line 8 foo\nsub t091 (\@#foo\na) { }";
1120 like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(\@"\n};
1121
1122 eval "#line 8 foo\nsub t092 (\% #foo\na) { }";
1123 is $@, "";
1124
1125 eval "#line 8 foo\nsub t093 (\%#foo\na) { }";
1126 like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(%"\n};
1127
1128 eval "#line 8 foo\nsub t094 (123) { }";
1129 like $@, qr{\AA signature parameter must start with '\$', '\@' or '%' at foo line 8, near "\(1"\n};
1130
1131 eval "#line 8 foo\nsub t095 (\$a, 123) { }";
1132 is $@, <<EOF;
1133 A signature parameter must start with '\$', '\@' or '%' at foo line 8, near ", 1"
1134 syntax error at foo line 8, near ", 123"
1135 Execution of foo aborted due to compilation errors.
1136 EOF
1137
1138 eval "#line 8 foo\nno warnings; sub t096 (\$a 123) { }";
1139 is $@, <<'EOF';
1140 Illegal operator following parameter in a subroutine signature at foo line 8, near "($a 123"
1141 syntax error at foo line 8, near "($a 123"
1142 Execution of foo aborted due to compilation errors.
1143 EOF
1144
1145 eval "#line 8 foo\nsub t097 (\$a { }) { }";
1146 is $@, <<'EOF';
1147 Illegal operator following parameter in a subroutine signature at foo line 8, near "($a { }"
1148 syntax error at foo line 8, near "($a { }"
1149 Execution of foo aborted due to compilation errors.
1150 EOF
1151
1152 eval "#line 8 foo\nsub t098 (\$a; \$b) { }";
1153 is $@, <<'EOF';
1154 Illegal operator following parameter in a subroutine signature at foo line 8, near "($a; "
1155 syntax error at foo line 8, near "($a; "
1156 Execution of foo aborted due to compilation errors.
1157 EOF
1158
1159 eval "#line 8 foo\nsub t099 (\$\$) { }";
1160 is $@, <<EOF;
1161 Illegal character following sigil in a subroutine signature at foo line 8, near "(\$"
1162 syntax error at foo line 8, near "\$\$) "
1163 Execution of foo aborted due to compilation errors.
1164 EOF
1165
1166 eval "#line 8 foo\nsub t101 (\@_) { }";
1167 like $@, qr/\ACan't use global \@_ in subroutine signature at foo line 8/;
1168
1169 eval "#line 8 foo\nsub t102 (\%_) { }";
1170 like $@, qr/\ACan't use global \%_ in subroutine signature at foo line 8/;
1171
1172 my $t103 = sub ($a) { $a || "z" };
1173 is prototype($t103), undef;
1174 is eval("\$t103->()"), undef;
1175 like $@, _create_mismatch_regexp('main::__ANON__', 0, 1);
1176 is eval("\$t103->(0)"), "z";
1177 is eval("\$t103->(456)"), 456;
1178 is eval("\$t103->(456, 789)"), undef;
1179 like $@, _create_mismatch_regexp('main::__ANON__', 2, 1);
1180 is eval("\$t103->(456, 789, 987)"), undef;
1181 like $@, _create_mismatch_regexp('main::__ANON__', 3, 1);
1182 is $a, 123;
1183
1184 my $t118 = sub :prototype($) ($a) { $a || "z" };
1185 is prototype($t118), "\$";
1186 is eval("\$t118->()"), undef;
1187 like $@, _create_mismatch_regexp('main::__ANON__', 0, 1);
1188 is eval("\$t118->(0)"), "z";
1189 is eval("\$t118->(456)"), 456;
1190 is eval("\$t118->(456, 789)"), undef;
1191 like $@, _create_mismatch_regexp('main::__ANON__', 2, 1);
1192 is eval("\$t118->(456, 789, 987)"), undef;
1193 like $@, _create_mismatch_regexp('main::__ANON__', 3, 1);
1194 is $a, 123;
1195
1196 sub t033 ($a = sub ($a) { $a."z" }) { $a->("a")."y" }
1197 is prototype(\&t033), undef;
1198 is eval("t033()"), "azy";
1199 is eval("t033(sub { \"x\".\$_[0].\"x\" })"), "xaxy";
1200 is eval("t033(sub { \"x\".\$_[0].\"x\" }, 789)"), undef;
1201 like $@, _create_flexible_mismatch_regexp('main::t033', 2, 1);
1202 is $a, 123;
1203
1204 sub t133 ($a = sub ($a = 222) { $a."z" }) { $a->()."/".$a->("a") }
1205 is prototype(\&t133), undef;
1206 is eval("t133()"), "222z/az";
1207 is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" })"), "xux/xax";
1208 is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" }, 789)"), undef;
1209 like $@, _create_flexible_mismatch_regexp('main::t133', 2, 1);
1210 is $a, 123;
1211
1212 sub t134 ($a = sub ($a, $t = sub { $_[0]."p" }) { $t->($a)."z" }) {
1213     $a->("a")."/".$a->("b", sub { $_[0]."q" } )
1214 }
1215 is prototype(\&t134), undef;
1216 is eval("t134()"), "apz/bqz";
1217 is eval("t134(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" })"),
1218     "xax/xbqx";
1219 is eval("t134(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
1220     undef;
1221 like $@, _create_flexible_mismatch_regexp('main::t134', 2, 1);
1222 is $a, 123;
1223
1224 sub t135 ($a = sub ($a, $t = sub ($p) { $p."p" }) { $t->($a)."z" }) {
1225     $a->("a")."/".$a->("b", sub { $_[0]."q" } )
1226 }
1227 is prototype(\&t135), undef;
1228 is eval("t135()"), "apz/bqz";
1229 is eval("t135(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" })"),
1230     "xax/xbqx";
1231 is eval("t135(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
1232     undef;
1233 like $@, _create_flexible_mismatch_regexp('main::t135', 2, 1);
1234 is $a, 123;
1235
1236 sub t132 (
1237     $a = sub ($a, $t = sub ($p = 222) { $p."p" }) { $t->($a)."z".$t->() },
1238 ) {
1239     $a->("a")."/".$a->("b", sub { ($_[0] // "u")."q" } )
1240 }
1241 is prototype(\&t132), undef;
1242 is eval("t132()"), "apz222p/bqzuq";
1243 is eval("t132(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" })"),
1244     "xax/xbqx";
1245 is eval("t132(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
1246     undef;
1247 like $@, _create_flexible_mismatch_regexp('main::t132', 2, 1);
1248 is $a, 123;
1249
1250 sub t104 :method ($a) { $a || "z" }
1251 is prototype(\&t104), undef;
1252 is eval("t104()"), undef;
1253 like $@, _create_mismatch_regexp('main::t104', 0, 1);
1254 is eval("t104(0)"), "z";
1255 is eval("t104(456)"), 456;
1256 is eval("t104(456, 789)"), undef;
1257 like $@, _create_mismatch_regexp('main::t104', 2, 1);
1258 is eval("t104(456, 789, 987)"), undef;
1259 like $@, _create_mismatch_regexp('main::t104', 3, 1);
1260 is $a, 123;
1261
1262 sub t105 :prototype($) ($a) { $a || "z" }
1263 is prototype(\&t105), "\$";
1264 is eval("t105()"), undef;
1265 like $@, qr/\ANot enough arguments for main::t105 /;
1266 is eval("t105(0)"), "z";
1267 is eval("t105(456)"), 456;
1268 is eval("t105(456, 789)"), undef;
1269 like $@, qr/\AToo many arguments for main::t105 at \(eval \d+\) line 1, near/;
1270 is eval("t105(456, 789, 987)"), undef;
1271 like $@, qr/\AToo many arguments for main::t105 at \(eval \d+\) line 1, near/;
1272 is $a, 123;
1273
1274 sub t106 :prototype(@) ($a) { $a || "z" }
1275 is prototype(\&t106), "\@";
1276 is eval("t106()"), undef;
1277 like $@, _create_mismatch_regexp('main::t106', 0, 1);
1278 is eval("t106(0)"), "z";
1279 is eval("t106(456)"), 456;
1280 is eval("t106(456, 789)"), undef;
1281 like $@, _create_mismatch_regexp('main::t106', 2, 1);
1282 is eval("t106(456, 789, 987)"), undef;
1283 like $@, _create_mismatch_regexp('main::t106', 3, 1);
1284 is $a, 123;
1285
1286 eval "#line 8 foo\nsub t107(\$a) :method { }";
1287 isnt $@, "";
1288
1289 eval "#line 8 foo\nsub t108 (\$a) :prototype(\$) { }";
1290 isnt $@, "";
1291
1292 sub t109 { }
1293 is prototype(\&t109), undef;
1294 is scalar(@{[ t109() ]}), 0;
1295 is scalar(t109()), undef;
1296
1297 sub t110 () { }
1298 is prototype(\&t110), undef;
1299 is scalar(@{[ t110() ]}), 0;
1300 is scalar(t110()), undef;
1301
1302 sub t111 ($a) { }
1303 is prototype(\&t111), undef;
1304 is scalar(@{[ t111(222) ]}), 0;
1305 is scalar(t111(222)), undef;
1306
1307 sub t112 ($) { }
1308 is prototype(\&t112), undef;
1309 is scalar(@{[ t112(222) ]}), 0;
1310 is scalar(t112(222)), undef;
1311
1312 sub t114 ($a = undef) { }
1313 is prototype(\&t114), undef;
1314 is scalar(@{[ t114() ]}), 0;
1315 is scalar(t114()), undef;
1316 is scalar(@{[ t114(333) ]}), 0;
1317 is scalar(t114(333)), undef;
1318
1319 sub t113 ($a = 222) { }
1320 is prototype(\&t113), undef;
1321 is scalar(@{[ t113() ]}), 0;
1322 is scalar(t113()), undef;
1323 is scalar(@{[ t113(333) ]}), 0;
1324 is scalar(t113(333)), undef;
1325
1326 sub t115 ($a = do { $z++; 222 }) { }
1327 is prototype(\&t115), undef;
1328 $z = 0;
1329 is scalar(@{[ t115() ]}), 0;
1330 is $z, 1;
1331 is scalar(t115()), undef;
1332 is $z, 2;
1333 is scalar(@{[ t115(333) ]}), 0;
1334 is scalar(t115(333)), undef;
1335 is $z, 2;
1336
1337 sub t116 (@a) { }
1338 is prototype(\&t116), undef;
1339 is scalar(@{[ t116() ]}), 0;
1340 is scalar(t116()), undef;
1341 is scalar(@{[ t116(333) ]}), 0;
1342 is scalar(t116(333)), undef;
1343
1344 sub t117 (%a) { }
1345 is prototype(\&t117), undef;
1346 is scalar(@{[ t117() ]}), 0;
1347 is scalar(t117()), undef;
1348 is scalar(@{[ t117(333, 444) ]}), 0;
1349 is scalar(t117(333, 444)), undef;
1350
1351 sub t145 ($=3) { }
1352 is scalar(t145()), undef;
1353
1354 {
1355     my $want;
1356     sub want { $want = wantarray ? "list"
1357                         : defined(wantarray) ? "scalar" : "void"; 1 }
1358
1359     sub t144 ($a = want()) { $a }
1360     t144();
1361     is ($want, "scalar", "default expression is scalar in void context");
1362     my $x = t144();
1363     is ($want, "scalar", "default expression is scalar in scalar context");
1364     () = t144();
1365     is ($want, "scalar", "default expression is scalar in list context");
1366 }
1367
1368
1369 # check for default arg code doing nasty things (closures, gotos,
1370 # modifying @_ etc).
1371
1372 {
1373     no warnings qw(closure);
1374     use Tie::Array;
1375     use Tie::Hash;
1376
1377     sub t146 ($a = t146x()) {
1378         sub t146x { $a = "abc"; 1 }
1379         $a;
1380     }
1381     is t146(), 1, "t146: closure can make new lexical not undef";
1382
1383     sub t147 ($a = t147x()) {
1384         sub t147x { $a = "abc"; pos($a)=1; 1 }
1385         is pos($a), undef, "t147: pos magic cleared";
1386         $a;
1387     }
1388     is t147(), 1, "t147: closure can make new lexical not undef and magical";
1389
1390     sub t148 ($a = t148x()) {
1391         sub t148x { $a = [];  1 }
1392         $a;
1393     }
1394     is t148(), 1, "t148: closure can make new lexical a ref";
1395
1396     sub t149 ($a = t149x()) {
1397         sub t149x { $a = 1;  [] }
1398         $a;
1399     }
1400     is ref(t149()), "ARRAY", "t149: closure can make new lexical a ref";
1401
1402     # Quiet the 'use of @_ is experimental' warnings
1403     no warnings 'experimental::args_array_with_signatures';
1404
1405     sub t150 ($a = do {@_ = qw(a b c); 1}, $b = 2) {
1406         is $a, 1,   "t150: a: growing \@_";
1407         is $b, "b", "t150: b: growing \@_";
1408     }
1409     t150();
1410
1411     sub t151 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, $b = 2) {
1412         is $a, 1,   "t151: a: tied \@_";
1413         is $b, "b", "t151: b: tied \@_";
1414     }
1415     t151();
1416
1417     sub t152 ($a = t152x(), @b) {
1418         sub t152x { @b = qw(a b c); 1 }
1419         $a . '-' . join(':', @b);
1420     }
1421     is t152(), "1-", "t152: closure can make new lexical array non-empty";
1422
1423     sub t153 ($a = t153x(), %b) {
1424         sub t153x { %b = qw(a 10 b 20); 1 }
1425         $a . '-' . join(':', sort %b);
1426     }
1427     is t153(), "1-", "t153: closure can make new lexical hash non-empty";
1428
1429     sub t154 ($a = t154x(), @b) {
1430         sub t154x { tie @b, 'Tie::StdArray'; @b = qw(a b c); 1 }
1431         $a . '-' . join(':', @b);
1432     }
1433     is t154(), "1-", "t154: closure can make new lexical array tied";
1434
1435     sub t155 ($a = t155x(), %b) {
1436         sub t155x { tie %b, 'Tie::StdHash'; %b = qw(a 10 b 20); 1 }
1437         $a . '-' . join(':', sort %b);
1438     }
1439     is t155(), "1-", "t155: closure can make new lexical hash tied";
1440
1441     sub t156 ($a = do {@_ = qw(a b c); 1}, @b) {
1442         is $a, 1,       "t156: a: growing \@_";
1443         is "@b", "b c", "t156: b: growing \@_";
1444     }
1445     t156();
1446
1447     sub t157 ($a = do {@_ = qw(a b c); 1}, %b) {
1448         is $a, 1,                     "t157: a: growing \@_";
1449         is join(':', sort %b), "b:c", "t157: b: growing \@_";
1450     }
1451     t157();
1452
1453     sub t158 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, @b) {
1454         is $a, 1,          "t158: a: tied \@_";
1455         is "@b", "b c",    "t158: b: tied \@_";
1456     }
1457     t158();
1458
1459     sub t159 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, %b) {
1460         is  $a, 1,                     "t159: a: tied \@_";
1461         is  join(':', sort %b), "b:c", "t159: b: tied \@_";
1462     }
1463     t159();
1464
1465     # see if we can handle the equivalent of @a = ($a[1], $a[0])
1466
1467     sub t160 ($s, @a) {
1468         sub t160x {
1469             @a = qw(x y);
1470             t160(1, $a[1], $a[0]);
1471         }
1472         # encourage recently-freed SVPVs to be realloced with new values
1473         my @pad = qw(a b);
1474         join ':', $s, @a;
1475     }
1476     is t160x(), "1:y:x", 'handle commonality in slurpy array';
1477
1478     # see if we can handle the equivalent of %h = ('foo', $h{foo})
1479
1480     sub t161 ($s, %h) {
1481         sub t161x {
1482             %h = qw(k1 v1 k2 v2);
1483             t161(1, k1 => $h{k2}, k2 => $h{k1});
1484         }
1485         # encourage recently-freed SVPVs to be realloced with new values
1486         my @pad = qw(a b);
1487         join ' ', $s, map "($_,$h{$_})", sort keys %h;
1488     }
1489     is t161x(), "1 (k1,v2) (k2,v1)", 'handle commonality in slurpy hash';
1490
1491     # see if we can handle the equivalent of ($a,$b) = ($b,$a)
1492     # Note that for non-signatured subs, my ($a,$b) = @_ already fails the
1493     # equivalent of this test too, since I skipped pessimising it
1494     # (90ce4d057857) as commonality in this case is rare and contrived,
1495     # as the example below shows. DAPM.
1496     sub t162 ($a, $b) {
1497         sub t162x {
1498             ($a, $b) = qw(x y);
1499             t162($b, $a);
1500         }
1501         "$a:$b";
1502     }
1503     {
1504         local $::TODO = q{can't handle commonaility};
1505         is t162x(), "y:x", 'handle commonality in scalar parms';
1506     }
1507 }
1508
1509 {
1510     my $w;
1511     local $SIG{__WARN__} = sub { $w .= "@_" };
1512     is eval q{sub ($x,$x) { $x}->(1,2)}, 2, "duplicate sig var names";
1513     like $w, qr/^"my" variable \$x masks earlier declaration in same scope/,
1514             "masking warning";
1515 }
1516
1517 # Reporting subroutine names
1518
1519 package T200 {
1520     sub foo ($x) {}
1521     *t201 = sub ($x) {}
1522 }
1523 *t202 = sub ($x) {};
1524 my $t203 = sub ($x) {};
1525 *t204 = *T200::foo;
1526 *t205 = \&T200::foo;
1527
1528 eval { T200::foo() };
1529 like($@, qr/^Too few arguments for subroutine 'T200::foo'/);
1530 eval { T200::t201() };
1531 like($@, qr/^Too few arguments for subroutine 'T200::__ANON__'/);
1532 eval { t202() };
1533 like($@, qr/^Too few arguments for subroutine 'main::__ANON__'/);
1534 eval { $t203->() };
1535 like($@, qr/^Too few arguments for subroutine 'main::__ANON__'/);
1536 eval { t204() };
1537 like($@, qr/^Too few arguments for subroutine 'T200::foo'/);
1538 eval { t205() };
1539 like($@, qr/^Too few arguments for subroutine 'T200::foo'/);
1540
1541
1542 # RT #130661 a char >= 0x80 in a signature when a sigil was expected
1543 # was triggering an assertion
1544
1545 eval "sub (\x80";
1546 like $@, qr/A signature parameter must start with/, "RT #130661";
1547
1548
1549
1550 use File::Spec::Functions;
1551 my $keywords_file = catfile(updir,'regen','keywords.pl');
1552 open my $kh, $keywords_file
1553    or die "$0 cannot open $keywords_file: $!";
1554 while(<$kh>) {
1555     if (m?__END__?..${\0} and /^[+-]/) {
1556         chomp(my $word = $');
1557         # $y should be an error after $x=foo.  The exact error we get may
1558         # differ if this is __END__ or s or some other special keyword.
1559         eval 'no warnings; sub ($x = ' . $word . ', $y) {}';
1560         isnt $@, "", "$word does not swallow trailing comma";
1561     }
1562 }
1563
1564 # RT #132141
1565 # Attributes such as lvalue have to come *before* the signature to
1566 # ensure that they're applied to any code block within the signature
1567
1568 {
1569     my $x;
1570     sub f :lvalue ($a = do { $x = "abc"; return substr($x,0,1)}) {
1571         die; # notreached
1572     }
1573
1574     f() = "X";
1575     is $x, "Xbc", "RT #132141";
1576 }
1577
1578 # RT #132760
1579 # attributes have been moved back before signatures for 5.28. Ensure that
1580 # code doing it the old wrong way get a meaningful error message.
1581
1582 {
1583     my @errs;
1584     local $SIG{__WARN__} = sub { push @errs, @_};
1585     eval q{
1586         sub rt132760 ($a, $b) :prototype($$) { $a + $b }
1587     };
1588
1589     @errs = split /\n/, $@;
1590     is +@errs, 1, "RT 132760 expect 1 error";
1591     like $errs[0],
1592         qr/^Subroutine attributes must come before the signature at/,
1593         "RT 132760 err 0";
1594 }
1595
1596 # check that warnings come from the correct line
1597
1598 {
1599     my @warn;
1600     local $SIG{__WARN__} = sub { push @warn, @_};
1601     eval q{
1602         sub multiline1 (
1603             $a,
1604             $b = $a + 1,
1605             $c = $a + 1)
1606         {
1607             my $d = $a + 1;
1608             my $e = $a + 1;
1609         }
1610     };
1611     multiline1(undef);
1612     like $warn[0], qr/line 4,/, 'multiline1: $b';
1613     like $warn[1], qr/line 5,/, 'multiline1: $c';
1614     like $warn[2], qr/line 7,/, 'multiline1: $d';
1615     like $warn[3], qr/line 8,/, 'multiline1: $e';
1616 }
1617
1618 # check errors for using global vars as params
1619
1620 {
1621     eval q{ sub ($_) {} };
1622     like $@, qr/Can't use global \$_ in subroutine signature/, 'f($_)';
1623     eval q{ sub (@_) {} };
1624     like $@, qr/Can't use global \@_ in subroutine signature/, 'f(@_)';
1625     eval q{ sub (%_) {} };
1626     like $@, qr/Can't use global \%_ in subroutine signature/, 'f(%_)';
1627     eval q{ sub ($1) {} };
1628     like $@, qr/Illegal operator following parameter in a subroutine signature/,
1629             'f($1)';
1630 }
1631
1632 # check that various uses of @_ inside signatured subs causes "experimental"
1633 # warnings at compiletime
1634 {
1635     sub warnings_from {
1636         my ($code, $run) = @_;
1637         my $warnings = "";
1638         local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
1639         my $cv = eval qq{ sub(\$x) { $code }} or die "Cannot eval() - $@";
1640         $run and $cv->(123);
1641         return $warnings;
1642     }
1643
1644     sub snailwarns_ok {
1645         my ($opname, $code) = @_;
1646         my $warnings = warnings_from $code;
1647         ok($warnings =~ m/[Uu]se of \@_ in $opname with signatured subroutine is experimental at \(eval /,
1648             "`$code` warns of experimental \@_") or
1649             diag("Warnings were:\n$warnings");
1650     }
1651
1652     sub snailwarns_runtime_ok {
1653         my ($opname, $code) = @_;
1654         my $warnings = warnings_from $code, 1;
1655         ok($warnings =~ m/[Uu]se of \@_ in $opname with signatured subroutine is experimental at \(eval /,
1656             "`$code` warns of experimental \@_") or
1657             diag("Warnings were:\n$warnings");
1658     }
1659
1660     sub not_snailwarns_ok {
1661         my ($code) = @_;
1662         my $warnings = warnings_from $code;
1663         ok($warnings !~ m/[Uu]se of \@_ in .* with signatured subroutine is experimental at \(eval /,
1664             "`$code` warns of experimental \@_") or
1665             diag("Warnings were:\n$warnings");
1666     }
1667
1668     # implicit @_
1669     snailwarns_ok 'shift',            'shift';
1670     snailwarns_ok 'pop',              'pop';
1671     snailwarns_ok 'goto',             'goto &SUB'; # tail-call
1672     snailwarns_ok 'subroutine entry', '&SUB'; # perl4-style
1673
1674     # explicit @_
1675     snailwarns_ok 'shift',            'shift @_';
1676     snailwarns_ok 'pop',              'pop @_';
1677     snailwarns_ok 'array element',    '$_[0]';
1678     snailwarns_ok 'array element',    'my $one = 1; $_[$one]';
1679     snailwarns_ok 'push',             'push @_, 1';
1680     snailwarns_ok 'unshift',          'unshift @_, 9';
1681     snailwarns_ok 'splice',           'splice @_, 1, 2, 3';
1682     snailwarns_ok 'keys on array',    'keys @_';
1683     snailwarns_ok 'values on array',  'values @_';
1684     snailwarns_ok 'each on array',    'each @_';
1685     snailwarns_ok 'print',            'print "a", @_, "z"';
1686     snailwarns_ok 'subroutine entry', 'func("a", @_, "z")';
1687
1688     # Also warns about @_ inside the signature params
1689     like(warnings_from('sub ($x = shift) { }'),
1690         qr/^Implicit use of \@_ in shift with signatured subroutine is experimental at \(eval /,
1691         'Warns of experimental @_ in param default');
1692     like(warnings_from('sub ($x = $_[0]) { }'),
1693         qr/^Use of \@_ in array element with signatured subroutine is experimental at \(eval /,
1694         'Warns of experimental @_ in param default');
1695
1696     # Inside eval() still counts, at runtime
1697     snailwarns_runtime_ok 'array element', 'eval q( $_[0] )';
1698
1699     # still permitted without warning
1700     not_snailwarns_ok 'my $f = sub { my $y = shift; }';
1701     not_snailwarns_ok 'my $f = sub { my $y = $_[0]; }';
1702     not_snailwarns_ok '\&SUB';
1703 }
1704
1705 # Warnings can be disabled
1706 {
1707     my $warnings = "";
1708     local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
1709     eval q{
1710         no warnings 'experimental::snail_in_signatures';
1711         sub($x) { @_ = (1,2,3) }
1712     };
1713     is($warnings, "", 'No warnings emitted within scope of  no warnings "experimental"');
1714 }
1715
1716 done_testing;
1717
1718 1;