1#!perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9use warnings; 10use strict; 11 12our $a = 123; 13our $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 23eval "#line 8 foo\nsub t004 :method (\$a) { }"; 24like $@, qr{syntax error at foo line 8}, "error when not enabled 1"; 25 26eval "#line 8 foo\nsub t005 (\$) (\$a) { }"; 27like $@, qr{syntax error at foo line 8}, "error when not enabled 2"; 28 29 30use feature "signatures"; 31 32sub t001 { $a || "z" } 33is prototype(\&t001), undef; 34is eval("t001()"), 123; 35is eval("t001(456)"), 123; 36is eval("t001(456, 789)"), 123; 37is $a, 123; 38 39sub _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 49sub _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 58sub t002 () { $a || "z" } 59is prototype(\&t002), undef; 60is eval("t002()"), 123; 61is eval("t002(456)"), undef; 62like $@, _create_mismatch_regexp('main::t002', 1, 0); 63is eval("t002(456, 789)"), undef; 64like $@, _create_mismatch_regexp('main::t002', 2, 0); 65is $a, 123; 66 67sub t003 ( ) { $a || "z" } 68is prototype(\&t003), undef; 69is eval("t003()"), 123; 70is eval("t003(456)"), undef; 71like $@, _create_mismatch_regexp('main::t003', 1, 0); 72is eval("t003(456, 789)"), undef; 73like $@, _create_mismatch_regexp('main::t003', 2, 0); 74is $a, 123; 75 76sub t006 ($a) { $a || "z" } 77is prototype(\&t006), undef; 78is eval("t006()"), undef; 79like $@, _create_mismatch_regexp('main::t006', 0, 1); 80is eval("t006(0)"), "z"; 81is eval("t006(456)"), 456; 82is eval("t006(456, 789)"), undef; 83like $@, _create_mismatch_regexp('main::t006', 2, 1); 84is eval("t006(456, 789, 987)"), undef; 85like $@, _create_mismatch_regexp('main::t006', 3, 1); 86is $a, 123; 87 88sub t007 ($a, $b) { $a.$b } 89is prototype(\&t007), undef; 90is eval("t007()"), undef; 91like $@, _create_mismatch_regexp('main::t007', 0, 2); 92is eval("t007(456)"), undef; 93like $@, _create_mismatch_regexp('main::t007', 1, 2); 94is eval("t007(456, 789)"), "456789"; 95is eval("t007(456, 789, 987)"), undef; 96like $@, _create_mismatch_regexp('main::t007', 3, 2); 97is eval("t007(456, 789, 987, 654)"), undef; 98like $@, _create_mismatch_regexp('main::t007', 4, 2); 99is $a, 123; 100 101sub t008 ($a, $b, $c) { $a.$b.$c } 102is prototype(\&t008), undef; 103is eval("t008()"), undef; 104like $@, _create_mismatch_regexp('main::t008', 0, 3); 105is eval("t008(456)"), undef; 106like $@, _create_mismatch_regexp('main::t008', 1, 3); 107is eval("t008(456, 789)"), undef; 108like $@, _create_mismatch_regexp('main::t008', 2, 3); 109is eval("t008(456, 789, 987)"), "456789987"; 110is eval("t008(456, 789, 987, 654)"), undef; 111like $@, _create_mismatch_regexp('main::t008', 4, 3); 112is $a, 123; 113 114sub t009 ($abc, $def) { $abc.$def } 115is prototype(\&t009), undef; 116is eval("t009()"), undef; 117like $@, _create_mismatch_regexp('main::t009', 0, 2); 118is eval("t009(456)"), undef; 119like $@, _create_mismatch_regexp('main::t009', 1, 2); 120is eval("t009(456, 789)"), "456789"; 121is eval("t009(456, 789, 987)"), undef; 122like $@, _create_mismatch_regexp('main::t009', 3, 2); 123is eval("t009(456, 789, 987, 654)"), undef; 124like $@, _create_mismatch_regexp('main::t009', 4, 2); 125is $a, 123; 126 127sub t010 ($a, $) { $a || "z" } 128is prototype(\&t010), undef; 129is eval("t010()"), undef; 130like $@, _create_mismatch_regexp('main::t010', 0, 2); 131is eval("t010(456)"), undef; 132like $@, _create_mismatch_regexp('main::t010', 1, 2); 133is eval("t010(0, 789)"), "z"; 134is eval("t010(456, 789)"), 456; 135is eval("t010(456, 789, 987)"), undef; 136like $@, _create_mismatch_regexp('main::t010', 3, 2); 137is eval("t010(456, 789, 987, 654)"), undef; 138like $@, _create_mismatch_regexp('main::t010', 4, 2); 139is $a, 123; 140 141sub t011 ($, $a) { $a || "z" } 142is prototype(\&t011), undef; 143is eval("t011()"), undef; 144like $@, _create_mismatch_regexp('main::t011', 0, 2); 145is eval("t011(456)"), undef; 146like $@, _create_mismatch_regexp('main::t011', 1, 2); 147is eval("t011(456, 0)"), "z"; 148is eval("t011(456, 789)"), 789; 149is eval("t011(456, 789, 987)"), undef; 150like $@, _create_mismatch_regexp('main::t011', 3, 2); 151is eval("t011(456, 789, 987, 654)"), undef; 152like $@, _create_mismatch_regexp('main::t011', 4, 2); 153is $a, 123; 154 155sub t012 ($, $) { $a || "z" } 156is prototype(\&t012), undef; 157is eval("t012()"), undef; 158like $@, _create_mismatch_regexp('main::t012', 0, 2); 159is eval("t012(456)"), undef; 160like $@, _create_mismatch_regexp('main::t012', 1, 2); 161is eval("t012(0, 789)"), 123; 162is eval("t012(456, 789)"), 123; 163is eval("t012(456, 789, 987)"), undef; 164like $@, _create_mismatch_regexp('main::t012', 3, 2); 165is eval("t012(456, 789, 987, 654)"), undef; 166like $@, _create_mismatch_regexp('main::t012', 4, 2); 167is $a, 123; 168 169sub t013 ($) { $a || "z" } 170is prototype(\&t013), undef; 171is eval("t013()"), undef; 172like $@, _create_mismatch_regexp('main::t013', 0, 1); 173is eval("t013(0)"), 123; 174is eval("t013(456)"), 123; 175is eval("t013(456, 789)"), undef; 176like $@, _create_mismatch_regexp('main::t013', 2, 1); 177is eval("t013(456, 789, 987)"), undef; 178like $@, _create_mismatch_regexp('main::t013', 3, 1); 179is eval("t013(456, 789, 987, 654)"), undef; 180like $@, _create_mismatch_regexp('main::t013', 4, 1); 181is $a, 123; 182 183sub t014 ($a = 222) { $a // "z" } 184is prototype(\&t014), undef; 185is eval("t014()"), 222; 186is eval("t014(0)"), 0; 187is eval("t014(undef)"), "z"; 188is eval("t014(456)"), 456; 189is eval("t014(456, 789)"), undef; 190like $@, _create_flexible_mismatch_regexp('main::t014', 2, 1); 191is eval("t014(456, 789, 987)"), undef; 192like $@, _create_flexible_mismatch_regexp('main::t014', 3, 1); 193is $a, 123; 194 195sub t015 ($a = undef) { $a // "z" } 196is prototype(\&t015), undef; 197is eval("t015()"), "z"; 198is eval("t015(0)"), 0; 199is eval("t015(undef)"), "z"; 200is eval("t015(456)"), 456; 201is eval("t015(456, 789)"), undef; 202like $@, _create_flexible_mismatch_regexp('main::t015', 2, 1); 203is eval("t015(456, 789, 987)"), undef; 204like $@, _create_flexible_mismatch_regexp('main::t015', 3, 1); 205is $a, 123; 206 207sub t016 ($a = do { $z++; 222 }) { $a // "z" } 208$z = 0; 209is prototype(\&t016), undef; 210is eval("t016()"), 222; 211is $z, 1; 212is eval("t016(0)"), 0; 213is eval("t016(undef)"), "z"; 214is eval("t016(456)"), 456; 215is eval("t016(456, 789)"), undef; 216like $@, _create_flexible_mismatch_regexp('main::t016', 2, 1); 217is eval("t016(456, 789, 987)"), undef; 218like $@, _create_flexible_mismatch_regexp('main::t016', 3, 1); 219is $z, 1; 220is eval("t016()"), 222; 221is $z, 2; 222is $a, 123; 223 224sub t018 { join("/", @_) } 225sub t017 ($p = t018 222, $a = 333) { $p // "z" } 226is prototype(\&t017), undef; 227is eval("t017()"), "222/333"; 228is $a, 333; 229$a = 123; 230is eval("t017(0)"), 0; 231is eval("t017(undef)"), "z"; 232is eval("t017(456)"), 456; 233is eval("t017(456, 789)"), undef; 234like $@, _create_flexible_mismatch_regexp('main::t017', 2, 1); 235is eval("t017(456, 789, 987)"), undef; 236like $@, _create_flexible_mismatch_regexp('main::t017', 3, 1); 237is $a, 123; 238 239sub t019 ($p = 222, $a = 333) { "$p/$a" } 240is prototype(\&t019), undef; 241is eval("t019()"), "222/333"; 242is eval("t019(0)"), "0/333"; 243is eval("t019(456)"), "456/333"; 244is eval("t019(456, 789)"), "456/789"; 245is eval("t019(456, 789, 987)"), undef; 246like $@, _create_flexible_mismatch_regexp('main::t019', 3, 2); 247is $a, 123; 248 249sub t020 :prototype($) { $_[0]."z" } 250sub t021 ($p = t020 222, $a = 333) { "$p/$a" } 251is prototype(\&t021), undef; 252is eval("t021()"), "222z/333"; 253is eval("t021(0)"), "0/333"; 254is eval("t021(456)"), "456/333"; 255is eval("t021(456, 789)"), "456/789"; 256is eval("t021(456, 789, 987)"), undef; 257like $@, _create_flexible_mismatch_regexp('main::t021', 3, 2); 258is $a, 123; 259 260sub t022 ($p = do { $z += 10; 222 }, $a = do { $z++; 333 }) { "$p/$a" } 261$z = 0; 262is prototype(\&t022), undef; 263is eval("t022()"), "222/333"; 264is $z, 11; 265is eval("t022(0)"), "0/333"; 266is $z, 12; 267is eval("t022(456)"), "456/333"; 268is $z, 13; 269is eval("t022(456, 789)"), "456/789"; 270is eval("t022(456, 789, 987)"), undef; 271like $@, _create_flexible_mismatch_regexp('main::t022', 3, 2); 272is $z, 13; 273is $a, 123; 274 275sub t023 ($a = sub { $_[0]."z" }) { $a->("a")."y" } 276is prototype(\&t023), undef; 277is eval("t023()"), "azy"; 278is eval("t023(sub { \"x\".\$_[0].\"x\" })"), "xaxy"; 279is eval("t023(sub { \"x\".\$_[0].\"x\" }, 789)"), undef; 280like $@, _create_flexible_mismatch_regexp('main::t023', 2, 1); 281is $a, 123; 282 283sub t036 ($a = $a."x") { $a."y" } 284is prototype(\&t036), undef; 285is eval("t036()"), "123xy"; 286is eval("t036(0)"), "0y"; 287is eval("t036(456)"), "456y"; 288is eval("t036(456, 789)"), undef; 289like $@, _create_flexible_mismatch_regexp('main::t036', 2, 1); 290is $a, 123; 291 292sub t120 ($a = $_) { $a // "z" } 293is prototype(\&t120), undef; 294$_ = "___"; 295is eval("t120()"), "___"; 296$_ = "___"; 297is eval("t120(undef)"), "z"; 298$_ = "___"; 299is eval("t120(0)"), 0; 300$_ = "___"; 301is eval("t120(456)"), 456; 302$_ = "___"; 303is eval("t120(456, 789)"), undef; 304like $@, _create_flexible_mismatch_regexp('main::t120', 2, 1); 305is $a, 123; 306 307sub t121 ($a = caller) { $a // "z" } 308is prototype(\&t121), undef; 309is eval("t121()"), "main"; 310is eval("t121(undef)"), "z"; 311is eval("t121(0)"), 0; 312is eval("t121(456)"), 456; 313is eval("t121(456, 789)"), undef; 314like $@, _create_flexible_mismatch_regexp('main::t121', 2, 1); 315is eval("package T121::Z; ::t121()"), "T121::Z"; 316is eval("package T121::Z; ::t121(undef)"), "z"; 317is eval("package T121::Z; ::t121(0)"), 0; 318is eval("package T121::Z; ::t121(456)"), 456; 319is eval("package T121::Z; ::t121(456, 789)"), undef; 320like $@, _create_flexible_mismatch_regexp('main::t121', 2, 1); 321is $a, 123; 322 323sub t129 ($a = return 222) { $a."x" } 324is prototype(\&t129), undef; 325is eval("t129()"), "222"; 326is eval("t129(0)"), "0x"; 327is eval("t129(456)"), "456x"; 328is eval("t129(456, 789)"), undef; 329like $@, _create_flexible_mismatch_regexp('main::t129', 2, 1); 330is $a, 123; 331 332use feature "current_sub"; 333sub t122 ($c = 5, $r = $c > 0 ? __SUB__->($c - 1) : "") { $c.$r } 334is prototype(\&t122), undef; 335is eval("t122()"), "543210"; 336is eval("t122(0)"), "0"; 337is eval("t122(1)"), "10"; 338is eval("t122(5)"), "543210"; 339is eval("t122(5, 789)"), "5789"; 340is eval("t122(5, 789, 987)"), undef; 341like $@, _create_flexible_mismatch_regexp('main::t122', 3, 2); 342is $a, 123; 343 344sub t123 ($list = wantarray) { $list ? "list" : "scalar" } 345is prototype(\&t123), undef; 346is eval("scalar(t123())"), "scalar"; 347is eval("(t123())[0]"), "list"; 348is eval("scalar(t123(0))"), "scalar"; 349is eval("(t123(0))[0]"), "scalar"; 350is eval("scalar(t123(1))"), "list"; 351is eval("(t123(1))[0]"), "list"; 352is eval("t123(456, 789)"), undef; 353like $@, _create_flexible_mismatch_regexp('main::t123', 2, 1); 354is $a, 123; 355 356sub t124 ($b = (local $a = $a + 1)) { "$a/$b" } 357is prototype(\&t124), undef; 358is eval("t124()"), "124/124"; 359is $a, 123; 360is eval("t124(456)"), "123/456"; 361is $a, 123; 362is eval("t124(456, 789)"), undef; 363like $@, _create_flexible_mismatch_regexp('main::t124', 2, 1); 364is $a, 123; 365 366sub t125 ($c = (our $t125_counter)++) { $c } 367is prototype(\&t125), undef; 368is eval("t125()"), 0; 369is eval("t125()"), 1; 370is eval("t125()"), 2; 371is eval("t125(456)"), 456; 372is eval("t125(789)"), 789; 373is eval("t125()"), 3; 374is eval("t125()"), 4; 375is eval("t125(456, 789)"), undef; 376like $@, _create_flexible_mismatch_regexp('main::t125', 2, 1); 377is $a, 123; 378 379use feature "state"; 380sub t126 ($c = (state $s = $z++)) { $c } 381is prototype(\&t126), undef; 382$z = 222; 383is eval("t126(456)"), 456; 384is $z, 222; 385is eval("t126()"), 222; 386is $z, 223; 387is eval("t126(456)"), 456; 388is $z, 223; 389is eval("t126()"), 222; 390is $z, 223; 391is eval("t126(456, 789)"), undef; 392like $@, _create_flexible_mismatch_regexp('main::t126', 2, 1); 393is $z, 223; 394is $a, 123; 395 396sub t127 ($c = do { state $s = $z++; $s++ }) { $c } 397is prototype(\&t127), undef; 398$z = 222; 399is eval("t127(456)"), 456; 400is $z, 222; 401is eval("t127()"), 222; 402is $z, 223; 403is eval("t127()"), 223; 404is eval("t127()"), 224; 405is $z, 223; 406is eval("t127(456)"), 456; 407is eval("t127(789)"), 789; 408is eval("t127()"), 225; 409is eval("t127()"), 226; 410is eval("t127(456, 789)"), undef; 411like $@, _create_flexible_mismatch_regexp('main::t127', 2, 1); 412is $z, 223; 413is $a, 123; 414 415sub t037 ($a = 222, $b = $a."x") { "$a/$b" } 416is prototype(\&t037), undef; 417is eval("t037()"), "222/222x"; 418is eval("t037(0)"), "0/0x"; 419is eval("t037(456)"), "456/456x"; 420is eval("t037(456, 789)"), "456/789"; 421is eval("t037(456, 789, 987)"), undef; 422like $@, _create_flexible_mismatch_regexp('main::t037', 3, 2); 423is $a, 123; 424 425sub t128 ($a = 222, $b = ($a = 333)) { "$a/$b" } 426is prototype(\&t128), undef; 427is eval("t128()"), "333/333"; 428is eval("t128(0)"), "333/333"; 429is eval("t128(456)"), "333/333"; 430is eval("t128(456, 789)"), "456/789"; 431is eval("t128(456, 789, 987)"), undef; 432like $@, _create_flexible_mismatch_regexp('main::t128', 3, 2); 433is $a, 123; 434 435sub t130 { join(",", @_).";".scalar(@_) } 436{ 437 no warnings 'experimental::args_array_with_signatures'; 438 sub t131 ($a = 222, $b = goto &t130) { "$a/$b" } 439} 440is prototype(\&t131), undef; 441is eval("t131()"), ";0"; 442is eval("t131(0)"), "0;1"; 443is eval("t131(456)"), "456;1"; 444is eval("t131(456, 789)"), "456/789"; 445is eval("t131(456, 789, 987)"), undef; 446like $@, _create_flexible_mismatch_regexp('main::t131', 3, 2); 447is $a, 123; 448 449eval "#line 8 foo\nsub t024 (\$a =) { }"; 450is $@, 451 qq{Optional parameter lacks default expression at foo line 8, near "=) "\n}; 452 453sub t025 ($ = undef) { $a // "z" } 454is prototype(\&t025), undef; 455is eval("t025()"), 123; 456is eval("t025(0)"), 123; 457is eval("t025(456)"), 123; 458is eval("t025(456, 789)"), undef; 459like $@, _create_flexible_mismatch_regexp('main::t025', 2, 1); 460is eval("t025(456, 789, 987)"), undef; 461like $@, _create_flexible_mismatch_regexp('main::t025', 3, 1); 462is eval("t025(456, 789, 987, 654)"), undef; 463like $@, _create_flexible_mismatch_regexp('main::t025', 4, 1); 464is $a, 123; 465 466sub t026 ($ = 222) { $a // "z" } 467is prototype(\&t026), undef; 468is eval("t026()"), 123; 469is eval("t026(0)"), 123; 470is eval("t026(456)"), 123; 471is eval("t026(456, 789)"), undef; 472like $@, _create_flexible_mismatch_regexp('main::t026', 2, 1); 473is eval("t026(456, 789, 987)"), undef; 474like $@, _create_flexible_mismatch_regexp('main::t026', 3, 1); 475is eval("t026(456, 789, 987, 654)"), undef; 476like $@, _create_flexible_mismatch_regexp('main::t026', 4, 1); 477is $a, 123; 478 479sub t032 ($ = do { $z++; 222 }) { $a // "z" } 480$z = 0; 481is prototype(\&t032), undef; 482is eval("t032()"), 123; 483is $z, 1; 484is eval("t032(0)"), 123; 485is eval("t032(456)"), 123; 486is eval("t032(456, 789)"), undef; 487like $@, _create_flexible_mismatch_regexp('main::t032', 2, 1); 488is eval("t032(456, 789, 987)"), undef; 489like $@, _create_flexible_mismatch_regexp('main::t032', 3, 1); 490is eval("t032(456, 789, 987, 654)"), undef; 491like $@, _create_flexible_mismatch_regexp('main::t032', 4, 1); 492is $z, 1; 493is $a, 123; 494 495sub t027 ($ =) { $a // "z" } 496is prototype(\&t027), undef; 497is eval("t027()"), 123; 498is eval("t027(0)"), 123; 499is eval("t027(456)"), 123; 500is eval("t027(456, 789)"), undef; 501like $@, _create_flexible_mismatch_regexp('main::t027', 2, 1); 502is eval("t027(456, 789, 987)"), undef; 503like $@, _create_flexible_mismatch_regexp('main::t027', 3, 1); 504is eval("t027(456, 789, 987, 654)"), undef; 505like $@, _create_flexible_mismatch_regexp('main::t027', 4, 1); 506is $a, 123; 507 508sub t119 ($ =, $a = 333) { $a // "z" } 509is prototype(\&t119), undef; 510is eval("t119()"), 333; 511is eval("t119(0)"), 333; 512is eval("t119(456)"), 333; 513is eval("t119(456, 789)"), 789; 514is eval("t119(456, 789, 987)"), undef; 515like $@, _create_flexible_mismatch_regexp('main::t119', 3, 2); 516is eval("t119(456, 789, 987, 654)"), undef; 517like $@, _create_flexible_mismatch_regexp('main::t119', 4, 2); 518is $a, 123; 519 520sub t028 ($a, $b = 333) { "$a/$b" } 521is prototype(\&t028), undef; 522is eval("t028()"), undef; 523like $@, _create_flexible_mismatch_regexp('main::t028', 0, 1); 524is eval("t028(0)"), "0/333"; 525is eval("t028(456)"), "456/333"; 526is eval("t028(456, 789)"), "456/789"; 527is eval("t028(456, 789, 987)"), undef; 528like $@, _create_flexible_mismatch_regexp('main::t028', 3, 2); 529is $a, 123; 530 531sub t045 ($a, $ = 333) { "$a/" } 532is prototype(\&t045), undef; 533is eval("t045()"), undef; 534like $@, _create_flexible_mismatch_regexp('main::t045', 0, 1); 535is eval("t045(0)"), "0/"; 536is eval("t045(456)"), "456/"; 537is eval("t045(456, 789)"), "456/"; 538is eval("t045(456, 789, 987)"), undef; 539like $@, _create_flexible_mismatch_regexp('main::t045', 3, 2); 540is $a, 123; 541 542sub t046 ($, $b = 333) { "$a/$b" } 543is prototype(\&t046), undef; 544is eval("t046()"), undef; 545like $@, _create_flexible_mismatch_regexp('main::t046', 0, 1); 546is eval("t046(0)"), "123/333"; 547is eval("t046(456)"), "123/333"; 548is eval("t046(456, 789)"), "123/789"; 549is eval("t046(456, 789, 987)"), undef; 550like $@, _create_flexible_mismatch_regexp('main::t046', 3, 2); 551is $a, 123; 552 553sub t047 ($, $ = 333) { "$a/" } 554is prototype(\&t047), undef; 555is eval("t047()"), undef; 556like $@, _create_flexible_mismatch_regexp('main::t047', 0, 1); 557is eval("t047(0)"), "123/"; 558is eval("t047(456)"), "123/"; 559is eval("t047(456, 789)"), "123/"; 560is eval("t047(456, 789, 987)"), undef; 561like $@, _create_flexible_mismatch_regexp('main::t047', 3, 2); 562is $a, 123; 563 564sub t029 ($a, $b, $c = 222, $d = 333) { "$a/$b/$c/$d" } 565is prototype(\&t029), undef; 566is eval("t029()"), undef; 567like $@, _create_flexible_mismatch_regexp('main::t029', 0, 2); 568is eval("t029(0)"), undef; 569like $@, _create_flexible_mismatch_regexp('main::t029', 1, 2); 570is eval("t029(456)"), undef; 571like $@, _create_flexible_mismatch_regexp('main::t029', 1, 2); 572is eval("t029(456, 789)"), "456/789/222/333"; 573is eval("t029(456, 789, 987)"), "456/789/987/333"; 574is eval("t029(456, 789, 987, 654)"), "456/789/987/654"; 575is eval("t029(456, 789, 987, 654, 321)"), undef; 576like $@, _create_flexible_mismatch_regexp('main::t029', 5, 4); 577is eval("t029(456, 789, 987, 654, 321, 111)"), undef; 578like $@, _create_flexible_mismatch_regexp('main::t029', 6, 4); 579is $a, 123; 580 581sub t038 ($a, $b = $a."x") { "$a/$b" } 582is prototype(\&t038), undef; 583is eval("t038()"), undef; 584like $@, _create_flexible_mismatch_regexp('main::t038', 0, 1); 585is eval("t038(0)"), "0/0x"; 586is eval("t038(456)"), "456/456x"; 587is eval("t038(456, 789)"), "456/789"; 588is eval("t038(456, 789, 987)"), undef; 589like $@, _create_flexible_mismatch_regexp('main::t038', 3, 2); 590is $a, 123; 591 592eval "#line 8 foo\nsub t030 (\$a = 222, \$b) { }"; 593is $@, qq{Mandatory parameter follows optional parameter at foo line 8, near "\$b) "\n}; 594 595eval "#line 8 foo\nsub t031 (\$a = 222, \$b = 333, \$c, \$d) { }"; 596is $@, <<EOF; 597Mandatory parameter follows optional parameter at foo line 8, near "\$c," 598Mandatory parameter follows optional parameter at foo line 8, near "\$d) " 599EOF 600 601sub t206 ($x, $y //= 3) { return $x + $y } 602is eval("t206(5,4)"), 9, '//= present'; 603is eval("t206(5)"), 8, '//= absent'; 604is eval("t206(4,undef)"), 7, '//= undef'; 605is eval("t206(4,0)"), 4, '//= zero'; 606 607sub t207 ($x, $y ||= 3) { return $x + $y } 608is eval("t207(5,4)"), 9, '||= present'; 609is eval("t207(5)"), 8, '||= absent'; 610is eval("t207(4,undef)"), 7, '||= undef'; 611is eval("t207(4,0)"), 7, '||= zero'; 612 613sub t034 (@abc) { join("/", @abc).";".scalar(@abc) } 614is prototype(\&t034), undef; 615is eval("t034()"), ";0"; 616is eval("t034(0)"), "0;1"; 617is eval("t034(456)"), "456;1"; 618is eval("t034(456, 789)"), "456/789;2"; 619is eval("t034(456, 789, 987)"), "456/789/987;3"; 620is eval("t034(456, 789, 987, 654)"), "456/789/987/654;4"; 621is eval("t034(456, 789, 987, 654, 321)"), "456/789/987/654/321;5"; 622is eval("t034(456, 789, 987, 654, 321, 111)"), "456/789/987/654/321/111;6"; 623is $a, 123; 624 625eval "#line 8 foo\nsub t136 (\@abc = 222) { }"; 626is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n}; 627 628eval "#line 8 foo\nsub t137 (\@abc =) { }"; 629is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n}; 630 631sub t035 (@) { $a } 632is prototype(\&t035), undef; 633is eval("t035()"), 123; 634is eval("t035(0)"), 123; 635is eval("t035(456)"), 123; 636is eval("t035(456, 789)"), 123; 637is eval("t035(456, 789, 987)"), 123; 638is eval("t035(456, 789, 987, 654)"), 123; 639is eval("t035(456, 789, 987, 654, 321)"), 123; 640is eval("t035(456, 789, 987, 654, 321, 111)"), 123; 641is $a, 123; 642 643eval "#line 8 foo\nsub t138 (\@ = 222) { }"; 644is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n}; 645 646eval "#line 8 foo\nsub t139 (\@ =) { }"; 647is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n}; 648 649sub t039 (%abc) { join("/", map { $_."=".$abc{$_} } sort keys %abc) } 650is prototype(\&t039), undef; 651is eval("t039()"), ""; 652is eval("t039(0)"), undef; 653like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#; 654is eval("t039(456)"), undef; 655like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#; 656is eval("t039(456, 789)"), "456=789"; 657is eval("t039(456, 789, 987)"), undef; 658like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#; 659is eval("t039(456, 789, 987, 654)"), "456=789/987=654"; 660is eval("t039(456, 789, 987, 654, 321)"), undef; 661like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#; 662is eval("t039(456, 789, 987, 654, 321, 111)"), "321=111/456=789/987=654"; 663is $a, 123; 664 665eval "#line 8 foo\nsub t140 (\%abc = 222) { }"; 666is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n}; 667 668eval "#line 8 foo\nsub t141 (\%abc =) { }"; 669is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n}; 670 671sub t040 (%) { $a } 672is prototype(\&t040), undef; 673is eval("t040()"), 123; 674is eval("t040(0)"), undef; 675like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#; 676is eval("t040(456)"), undef; 677like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#; 678is eval("t040(456, 789)"), 123; 679is eval("t040(456, 789, 987)"), undef; 680like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#; 681is eval("t040(456, 789, 987, 654)"), 123; 682is eval("t040(456, 789, 987, 654, 321)"), undef; 683like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#; 684is eval("t040(456, 789, 987, 654, 321, 111)"), 123; 685is $a, 123; 686 687eval "#line 8 foo\nsub t142 (\% = 222) { }"; 688is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n}; 689 690eval "#line 8 foo\nsub t143 (\% =) { }"; 691is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n}; 692 693sub t041 ($a, @b) { $a.";".join("/", @b) } 694is prototype(\&t041), undef; 695is eval("t041()"), undef; 696like $@, _create_flexible_mismatch_regexp('main::t041', 0, 1); 697is eval("t041(0)"), "0;"; 698is eval("t041(456)"), "456;"; 699is eval("t041(456, 789)"), "456;789"; 700is eval("t041(456, 789, 987)"), "456;789/987"; 701is eval("t041(456, 789, 987, 654)"), "456;789/987/654"; 702is eval("t041(456, 789, 987, 654, 321)"), "456;789/987/654/321"; 703is eval("t041(456, 789, 987, 654, 321, 111)"), "456;789/987/654/321/111"; 704is $a, 123; 705 706sub t042 ($a, @) { $a.";" } 707is prototype(\&t042), undef; 708is eval("t042()"), undef; 709like $@, _create_flexible_mismatch_regexp('main::t042', 0, 1); 710is eval("t042(0)"), "0;"; 711is eval("t042(456)"), "456;"; 712is eval("t042(456, 789)"), "456;"; 713is eval("t042(456, 789, 987)"), "456;"; 714is eval("t042(456, 789, 987, 654)"), "456;"; 715is eval("t042(456, 789, 987, 654, 321)"), "456;"; 716is eval("t042(456, 789, 987, 654, 321, 111)"), "456;"; 717is $a, 123; 718 719sub t043 ($, @b) { $a.";".join("/", @b) } 720is prototype(\&t043), undef; 721is eval("t043()"), undef; 722like $@, _create_flexible_mismatch_regexp('main::t043', 0, 1); 723is eval("t043(0)"), "123;"; 724is eval("t043(456)"), "123;"; 725is eval("t043(456, 789)"), "123;789"; 726is eval("t043(456, 789, 987)"), "123;789/987"; 727is eval("t043(456, 789, 987, 654)"), "123;789/987/654"; 728is eval("t043(456, 789, 987, 654, 321)"), "123;789/987/654/321"; 729is eval("t043(456, 789, 987, 654, 321, 111)"), "123;789/987/654/321/111"; 730is $a, 123; 731 732sub t044 ($, @) { $a.";" } 733is prototype(\&t044), undef; 734is eval("t044()"), undef; 735like $@, _create_flexible_mismatch_regexp('main::t044', 0, 1); 736is eval("t044(0)"), "123;"; 737is eval("t044(456)"), "123;"; 738is eval("t044(456, 789)"), "123;"; 739is eval("t044(456, 789, 987)"), "123;"; 740is eval("t044(456, 789, 987, 654)"), "123;"; 741is eval("t044(456, 789, 987, 654, 321)"), "123;"; 742is eval("t044(456, 789, 987, 654, 321, 111)"), "123;"; 743is $a, 123; 744 745sub t049 ($a, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) } 746is prototype(\&t049), undef; 747is eval("t049()"), undef; 748like $@, _create_flexible_mismatch_regexp('main::t049', 0, 1); 749is eval("t049(222)"), "222;"; 750is eval("t049(222, 456)"), undef; 751like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#; 752is eval("t049(222, 456, 789)"), "222;456=789"; 753is eval("t049(222, 456, 789, 987)"), undef; 754like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#; 755is eval("t049(222, 456, 789, 987, 654)"), "222;456=789/987=654"; 756is eval("t049(222, 456, 789, 987, 654, 321)"), undef; 757like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#; 758is eval("t049(222, 456, 789, 987, 654, 321, 111)"), 759 "222;321=111/456=789/987=654"; 760is $a, 123; 761 762sub t051 ($a, $b, $c, @d) { "$a;$b;$c;".join("/", @d).";".scalar(@d) } 763is prototype(\&t051), undef; 764is eval("t051()"), undef; 765like $@, _create_flexible_mismatch_regexp('main::t051', 0, 3); 766is eval("t051(456)"), undef; 767like $@, _create_flexible_mismatch_regexp('main::t051', 1, 3); 768is eval("t051(456, 789)"), undef; 769like $@, _create_flexible_mismatch_regexp('main::t051', 2, 3); 770is eval("t051(456, 789, 987)"), "456;789;987;;0"; 771is eval("t051(456, 789, 987, 654)"), "456;789;987;654;1"; 772is eval("t051(456, 789, 987, 654, 321)"), "456;789;987;654/321;2"; 773is eval("t051(456, 789, 987, 654, 321, 111)"), "456;789;987;654/321/111;3"; 774is $a, 123; 775 776sub t052 ($a, $b, %c) { "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c) } 777is prototype(\&t052), undef; 778is eval("t052()"), undef; 779like $@, _create_flexible_mismatch_regexp('main::t052', 0, 2); 780is eval("t052(222)"), undef; 781like $@, _create_flexible_mismatch_regexp('main::t052', 1, 2); 782is eval("t052(222, 333)"), "222;333;"; 783is eval("t052(222, 333, 456)"), undef; 784like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#; 785is eval("t052(222, 333, 456, 789)"), "222;333;456=789"; 786is eval("t052(222, 333, 456, 789, 987)"), undef; 787like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#; 788is eval("t052(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654"; 789is eval("t052(222, 333, 456, 789, 987, 654, 321)"), undef; 790like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#; 791is eval("t052(222, 333, 456, 789, 987, 654, 321, 111)"), 792 "222;333;321=111/456=789/987=654"; 793is $a, 123; 794 795sub t053 ($a, $b, $c, %d) { 796 "$a;$b;$c;".join("/", map { $_."=".$d{$_} } sort keys %d) 797} 798is prototype(\&t053), undef; 799is eval("t053()"), undef; 800like $@, _create_flexible_mismatch_regexp('main::t053', 0, 3); 801is eval("t053(222)"), undef; 802like $@, _create_flexible_mismatch_regexp('main::t053', 1, 3); 803is eval("t053(222, 333)"), undef; 804like $@, _create_flexible_mismatch_regexp('main::t053', 2, 3); 805is eval("t053(222, 333, 444)"), "222;333;444;"; 806is eval("t053(222, 333, 444, 456)"), undef; 807like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#; 808is eval("t053(222, 333, 444, 456, 789)"), "222;333;444;456=789"; 809is eval("t053(222, 333, 444, 456, 789, 987)"), undef; 810like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#; 811is eval("t053(222, 333, 444, 456, 789, 987, 654)"), 812 "222;333;444;456=789/987=654"; 813is eval("t053(222, 333, 444, 456, 789, 987, 654, 321)"), undef; 814like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#; 815is eval("t053(222, 333, 444, 456, 789, 987, 654, 321, 111)"), 816 "222;333;444;321=111/456=789/987=654"; 817is $a, 123; 818 819sub t048 ($a = 222, @b) { $a.";".join("/", @b).";".scalar(@b) } 820is prototype(\&t048), undef; 821is eval("t048()"), "222;;0"; 822is eval("t048(0)"), "0;;0"; 823is eval("t048(456)"), "456;;0"; 824is eval("t048(456, 789)"), "456;789;1"; 825is eval("t048(456, 789, 987)"), "456;789/987;2"; 826is eval("t048(456, 789, 987, 654)"), "456;789/987/654;3"; 827is eval("t048(456, 789, 987, 654, 321)"), "456;789/987/654/321;4"; 828is eval("t048(456, 789, 987, 654, 321, 111)"), "456;789/987/654/321/111;5"; 829is $a, 123; 830 831sub t054 ($a = 222, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) } 832is prototype(\&t054), undef; 833is eval("t054()"), "222;333;;0"; 834is eval("t054(456)"), "456;333;;0"; 835is eval("t054(456, 789)"), "456;789;;0"; 836is eval("t054(456, 789, 987)"), "456;789;987;1"; 837is eval("t054(456, 789, 987, 654)"), "456;789;987/654;2"; 838is eval("t054(456, 789, 987, 654, 321)"), "456;789;987/654/321;3"; 839is eval("t054(456, 789, 987, 654, 321, 111)"), "456;789;987/654/321/111;4"; 840is $a, 123; 841 842sub t055 ($a = 222, $b = 333, $c = 444, @d) { 843 "$a;$b;$c;".join("/", @d).";".scalar(@d) 844} 845is prototype(\&t055), undef; 846is eval("t055()"), "222;333;444;;0"; 847is eval("t055(456)"), "456;333;444;;0"; 848is eval("t055(456, 789)"), "456;789;444;;0"; 849is eval("t055(456, 789, 987)"), "456;789;987;;0"; 850is eval("t055(456, 789, 987, 654)"), "456;789;987;654;1"; 851is eval("t055(456, 789, 987, 654, 321)"), "456;789;987;654/321;2"; 852is eval("t055(456, 789, 987, 654, 321, 111)"), "456;789;987;654/321/111;3"; 853is $a, 123; 854 855sub t050 ($a = 211, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) } 856is prototype(\&t050), undef; 857is eval("t050()"), "211;"; 858is eval("t050(222)"), "222;"; 859is eval("t050(222, 456)"), undef; 860like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#; 861is eval("t050(222, 456, 789)"), "222;456=789"; 862is eval("t050(222, 456, 789, 987)"), undef; 863like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#; 864is eval("t050(222, 456, 789, 987, 654)"), "222;456=789/987=654"; 865is eval("t050(222, 456, 789, 987, 654, 321)"), undef; 866like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#; 867is eval("t050(222, 456, 789, 987, 654, 321, 111)"), 868 "222;321=111/456=789/987=654"; 869is $a, 123; 870 871sub t056 ($a = 211, $b = 311, %c) { 872 "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c) 873} 874is prototype(\&t056), undef; 875is eval("t056()"), "211;311;"; 876is eval("t056(222)"), "222;311;"; 877is eval("t056(222, 333)"), "222;333;"; 878is eval("t056(222, 333, 456)"), undef; 879like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#; 880is eval("t056(222, 333, 456, 789)"), "222;333;456=789"; 881is eval("t056(222, 333, 456, 789, 987)"), undef; 882like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#; 883is eval("t056(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654"; 884is eval("t056(222, 333, 456, 789, 987, 654, 321)"), undef; 885like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#; 886is eval("t056(222, 333, 456, 789, 987, 654, 321, 111)"), 887 "222;333;321=111/456=789/987=654"; 888is $a, 123; 889 890sub t057 ($a = 211, $b = 311, $c = 411, %d) { 891 "$a;$b;$c;".join("/", map { $_."=".$d{$_} } sort keys %d) 892} 893is prototype(\&t057), undef; 894is eval("t057()"), "211;311;411;"; 895is eval("t057(222)"), "222;311;411;"; 896is eval("t057(222, 333)"), "222;333;411;"; 897is eval("t057(222, 333, 444)"), "222;333;444;"; 898is eval("t057(222, 333, 444, 456)"), undef; 899like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#; 900is eval("t057(222, 333, 444, 456, 789)"), "222;333;444;456=789"; 901is eval("t057(222, 333, 444, 456, 789, 987)"), undef; 902like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#; 903is eval("t057(222, 333, 444, 456, 789, 987, 654)"), 904 "222;333;444;456=789/987=654"; 905is eval("t057(222, 333, 444, 456, 789, 987, 654, 321)"), undef; 906like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#; 907is eval("t057(222, 333, 444, 456, 789, 987, 654, 321, 111)"), 908 "222;333;444;321=111/456=789/987=654"; 909is $a, 123; 910 911sub t058 ($a, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) } 912is prototype(\&t058), undef; 913is eval("t058()"), undef; 914like $@, _create_flexible_mismatch_regexp('main::t058', 0, 1); 915is eval("t058(456)"), "456;333;;0"; 916is eval("t058(456, 789)"), "456;789;;0"; 917is eval("t058(456, 789, 987)"), "456;789;987;1"; 918is eval("t058(456, 789, 987, 654)"), "456;789;987/654;2"; 919is eval("t058(456, 789, 987, 654, 321)"), "456;789;987/654/321;3"; 920is eval("t058(456, 789, 987, 654, 321, 111)"), "456;789;987/654/321/111;4"; 921is $a, 123; 922 923eval "#line 8 foo\nsub t059 (\@a, \$b) { }"; 924is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n}; 925 926eval "#line 8 foo\nsub t060 (\@a, \$b = 222) { }"; 927is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n}; 928 929eval "#line 8 foo\nsub t061 (\@a, \@b) { }"; 930is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@b) "\n}; 931 932eval "#line 8 foo\nsub t062 (\@a, \%b) { }"; 933is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "%b) "\n}; 934 935eval "#line 8 foo\nsub t063 (\@, \$b) { }"; 936is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n}; 937 938eval "#line 8 foo\nsub t064 (\@, \$b = 222) { }"; 939is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n}; 940 941eval "#line 8 foo\nsub t065 (\@, \@b) { }"; 942is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@b) "\n}; 943 944eval "#line 8 foo\nsub t066 (\@, \%b) { }"; 945is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "%b) "\n}; 946 947eval "#line 8 foo\nsub t067 (\@a, \$) { }"; 948is $@, qq{Slurpy parameter not last at foo line 8, near "\$) "\n}; 949 950eval "#line 8 foo\nsub t068 (\@a, \$ = 222) { }"; 951is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n}; 952 953eval "#line 8 foo\nsub t069 (\@a, \@) { }"; 954is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@) "\n}; 955 956eval "#line 8 foo\nsub t070 (\@a, \%) { }"; 957is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\%) "\n}; 958 959eval "#line 8 foo\nsub t071 (\@, \$) { }"; 960is $@, qq{Slurpy parameter not last at foo line 8, near "\$) "\n}; 961 962eval "#line 8 foo\nsub t072 (\@, \$ = 222) { }"; 963is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n}; 964 965eval "#line 8 foo\nsub t073 (\@, \@) { }"; 966is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@) "\n}; 967 968eval "#line 8 foo\nsub t074 (\@, \%) { }"; 969is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\%) "\n}; 970 971eval "#line 8 foo\nsub t075 (\%a, \$b) { }"; 972is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n}; 973 974eval "#line 8 foo\nsub t076 (\%, \$b) { }"; 975is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n}; 976 977eval "#line 8 foo\nsub t077 (\$a, \@b, \$c) { }"; 978is $@, qq{Slurpy parameter not last at foo line 8, near "\$c) "\n}; 979 980eval "#line 8 foo\nsub t078 (\$a, \%b, \$c) { }"; 981is $@, qq{Slurpy parameter not last at foo line 8, near "\$c) "\n}; 982 983eval "#line 8 foo\nsub t079 (\$a, \@b, \$c, \$d) { }"; 984is $@, <<EOF; 985Slurpy parameter not last at foo line 8, near "\$c," 986Slurpy parameter not last at foo line 8, near "\$d) " 987EOF 988 989sub t080 ($a,,, $b) { $a.$b } 990is prototype(\&t080), undef; 991is eval("t080()"), undef; 992like $@, _create_mismatch_regexp('main::t080', 0, 2); 993is eval("t080(456)"), undef; 994like $@, _create_mismatch_regexp('main::t080', 1, 2); 995is eval("t080(456, 789)"), "456789"; 996is eval("t080(456, 789, 987)"), undef; 997like $@, _create_mismatch_regexp('main::t080', 3, 2); 998is eval("t080(456, 789, 987, 654)"), undef; 999like $@, _create_mismatch_regexp('main::t080', 4, 2); 1000is $a, 123; 1001 1002sub t081 ($a, $b,,) { $a.$b } 1003is prototype(\&t081), undef; 1004is eval("t081()"), undef; 1005like $@, _create_mismatch_regexp('main::t081', 0, 2); 1006is eval("t081(456)"), undef; 1007like $@, _create_mismatch_regexp('main::t081', 1, 2); 1008is eval("t081(456, 789)"), "456789"; 1009is eval("t081(456, 789, 987)"), undef; 1010like $@, _create_mismatch_regexp('main::t081', 3, 2); 1011is eval("t081(456, 789, 987, 654)"), undef; 1012like $@, _create_mismatch_regexp('main::t081', 4, 2); 1013is $a, 123; 1014 1015eval "#line 8 foo\nsub t082 (, \$a) { }"; 1016is $@, qq{syntax error at foo line 8, near "(,"\nExecution of foo aborted due to compilation errors.\n}; 1017 1018eval "#line 8 foo\nsub t083 (,) { }"; 1019is $@, qq{syntax error at foo line 8, near "(,"\nExecution of foo aborted due to compilation errors.\n}; 1020 1021sub t084($a,$b){ $a.$b } 1022is prototype(\&t084), undef; 1023is eval("t084()"), undef; 1024like $@, _create_mismatch_regexp('main::t084', 0, 2); 1025is eval("t084(456)"), undef; 1026like $@, _create_mismatch_regexp('main::t084', 1, 2); 1027is eval("t084(456, 789)"), "456789"; 1028is eval("t084(456, 789, 987)"), undef; 1029like $@, _create_mismatch_regexp('main::t084', 3, 2); 1030is eval("t084(456, 789, 987, 654)"), undef; 1031like $@, _create_mismatch_regexp('main::t084', 4, 2); 1032is $a, 123; 1033 1034sub t085 1035 ( 1036 $ 1037 a 1038 , 1039 , 1040 $ 1041 b 1042 = 1043 333 1044 , 1045 , 1046 ) 1047 { $a.$b } 1048is prototype(\&t085), undef; 1049is eval("t085()"), undef; 1050like $@, _create_flexible_mismatch_regexp('main::t085', 0, 1); 1051is eval("t085(456)"), "456333"; 1052is eval("t085(456, 789)"), "456789"; 1053is eval("t085(456, 789, 987)"), undef; 1054like $@, _create_flexible_mismatch_regexp('main::t085', 3, 2); 1055is eval("t085(456, 789, 987, 654)"), undef; 1056like $@, _create_flexible_mismatch_regexp('main::t085', 4, 2); 1057is $a, 123; 1058 1059sub 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 } 1073is prototype(\&t086), undef; 1074is eval("t086()"), undef; 1075like $@, _create_flexible_mismatch_regexp('main::t086', 0, 1); 1076is eval("t086(456)"), "456333"; 1077is eval("t086(456, 789)"), "456789"; 1078is eval("t086(456, 789, 987)"), undef; 1079like $@, _create_flexible_mismatch_regexp('main::t086', 3, 2); 1080is eval("t086(456, 789, 987, 654)"), undef; 1081like $@, _create_flexible_mismatch_regexp('main::t086', 4, 2); 1082is $a, 123; 1083 1084sub 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 } 1098is prototype(\&t087), undef; 1099is eval("t087()"), undef; 1100like $@, _create_flexible_mismatch_regexp('main::t087', 0, 1); 1101is eval("t087(456)"), "456333"; 1102is eval("t087(456, 789)"), "456789"; 1103is eval("t087(456, 789, 987)"), undef; 1104like $@, _create_flexible_mismatch_regexp('main::t087', 3, 2); 1105is eval("t087(456, 789, 987, 654)"), undef; 1106like $@, _create_flexible_mismatch_regexp('main::t087', 4, 2); 1107is $a, 123; 1108 1109eval "#line 8 foo\nsub t088 (\$ #foo\na) { }"; 1110is $@, ""; 1111 1112 1113eval "#line 8 foo\nsub t089 (\$#foo\na) { }"; 1114like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(\$"\n}; 1115 1116eval "#line 8 foo\nsub t090 (\@ #foo\na) { }"; 1117is $@, ""; 1118 1119eval "#line 8 foo\nsub t091 (\@#foo\na) { }"; 1120like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(\@"\n}; 1121 1122eval "#line 8 foo\nsub t092 (\% #foo\na) { }"; 1123is $@, ""; 1124 1125eval "#line 8 foo\nsub t093 (\%#foo\na) { }"; 1126like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(%"\n}; 1127 1128eval "#line 8 foo\nsub t094 (123) { }"; 1129like $@, qr{\AA signature parameter must start with '\$', '\@' or '%' at foo line 8, near "\(1"\n}; 1130 1131eval "#line 8 foo\nsub t095 (\$a, 123) { }"; 1132is $@, <<EOF; 1133A signature parameter must start with '\$', '\@' or '%' at foo line 8, near ", 1" 1134syntax error at foo line 8, near ", 123" 1135Execution of foo aborted due to compilation errors. 1136EOF 1137 1138eval "#line 8 foo\nno warnings; sub t096 (\$a 123) { }"; 1139is $@, <<'EOF'; 1140Illegal operator following parameter in a subroutine signature at foo line 8, near "($a 123" 1141syntax error at foo line 8, near "($a 123" 1142Execution of foo aborted due to compilation errors. 1143EOF 1144 1145eval "#line 8 foo\nsub t097 (\$a { }) { }"; 1146is $@, <<'EOF'; 1147Illegal operator following parameter in a subroutine signature at foo line 8, near "($a { }" 1148syntax error at foo line 8, near "($a { }" 1149Execution of foo aborted due to compilation errors. 1150EOF 1151 1152eval "#line 8 foo\nsub t098 (\$a; \$b) { }"; 1153is $@, <<'EOF'; 1154Illegal operator following parameter in a subroutine signature at foo line 8, near "($a; " 1155syntax error at foo line 8, near "($a; " 1156Execution of foo aborted due to compilation errors. 1157EOF 1158 1159eval "#line 8 foo\nsub t099 (\$\$) { }"; 1160is $@, <<EOF; 1161Illegal character following sigil in a subroutine signature at foo line 8, near "(\$" 1162syntax error at foo line 8, near "\$\$) " 1163Execution of foo aborted due to compilation errors. 1164EOF 1165 1166eval "#line 8 foo\nsub t101 (\@_) { }"; 1167like $@, qr/\ACan't use global \@_ in subroutine signature at foo line 8/; 1168 1169eval "#line 8 foo\nsub t102 (\%_) { }"; 1170like $@, qr/\ACan't use global \%_ in subroutine signature at foo line 8/; 1171 1172my $t103 = sub ($a) { $a || "z" }; 1173is prototype($t103), undef; 1174is eval("\$t103->()"), undef; 1175like $@, _create_mismatch_regexp('main::__ANON__', 0, 1); 1176is eval("\$t103->(0)"), "z"; 1177is eval("\$t103->(456)"), 456; 1178is eval("\$t103->(456, 789)"), undef; 1179like $@, _create_mismatch_regexp('main::__ANON__', 2, 1); 1180is eval("\$t103->(456, 789, 987)"), undef; 1181like $@, _create_mismatch_regexp('main::__ANON__', 3, 1); 1182is $a, 123; 1183 1184my $t118 = sub :prototype($) ($a) { $a || "z" }; 1185is prototype($t118), "\$"; 1186is eval("\$t118->()"), undef; 1187like $@, _create_mismatch_regexp('main::__ANON__', 0, 1); 1188is eval("\$t118->(0)"), "z"; 1189is eval("\$t118->(456)"), 456; 1190is eval("\$t118->(456, 789)"), undef; 1191like $@, _create_mismatch_regexp('main::__ANON__', 2, 1); 1192is eval("\$t118->(456, 789, 987)"), undef; 1193like $@, _create_mismatch_regexp('main::__ANON__', 3, 1); 1194is $a, 123; 1195 1196sub t033 ($a = sub ($a) { $a."z" }) { $a->("a")."y" } 1197is prototype(\&t033), undef; 1198is eval("t033()"), "azy"; 1199is eval("t033(sub { \"x\".\$_[0].\"x\" })"), "xaxy"; 1200is eval("t033(sub { \"x\".\$_[0].\"x\" }, 789)"), undef; 1201like $@, _create_flexible_mismatch_regexp('main::t033', 2, 1); 1202is $a, 123; 1203 1204sub t133 ($a = sub ($a = 222) { $a."z" }) { $a->()."/".$a->("a") } 1205is prototype(\&t133), undef; 1206is eval("t133()"), "222z/az"; 1207is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" })"), "xux/xax"; 1208is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" }, 789)"), undef; 1209like $@, _create_flexible_mismatch_regexp('main::t133', 2, 1); 1210is $a, 123; 1211 1212sub t134 ($a = sub ($a, $t = sub { $_[0]."p" }) { $t->($a)."z" }) { 1213 $a->("a")."/".$a->("b", sub { $_[0]."q" } ) 1214} 1215is prototype(\&t134), undef; 1216is eval("t134()"), "apz/bqz"; 1217is eval("t134(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" })"), 1218 "xax/xbqx"; 1219is eval("t134(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"), 1220 undef; 1221like $@, _create_flexible_mismatch_regexp('main::t134', 2, 1); 1222is $a, 123; 1223 1224sub t135 ($a = sub ($a, $t = sub ($p) { $p."p" }) { $t->($a)."z" }) { 1225 $a->("a")."/".$a->("b", sub { $_[0]."q" } ) 1226} 1227is prototype(\&t135), undef; 1228is eval("t135()"), "apz/bqz"; 1229is eval("t135(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" })"), 1230 "xax/xbqx"; 1231is eval("t135(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"), 1232 undef; 1233like $@, _create_flexible_mismatch_regexp('main::t135', 2, 1); 1234is $a, 123; 1235 1236sub 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} 1241is prototype(\&t132), undef; 1242is eval("t132()"), "apz222p/bqzuq"; 1243is eval("t132(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" })"), 1244 "xax/xbqx"; 1245is eval("t132(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"), 1246 undef; 1247like $@, _create_flexible_mismatch_regexp('main::t132', 2, 1); 1248is $a, 123; 1249 1250sub t104 :method ($a) { $a || "z" } 1251is prototype(\&t104), undef; 1252is eval("t104()"), undef; 1253like $@, _create_mismatch_regexp('main::t104', 0, 1); 1254is eval("t104(0)"), "z"; 1255is eval("t104(456)"), 456; 1256is eval("t104(456, 789)"), undef; 1257like $@, _create_mismatch_regexp('main::t104', 2, 1); 1258is eval("t104(456, 789, 987)"), undef; 1259like $@, _create_mismatch_regexp('main::t104', 3, 1); 1260is $a, 123; 1261 1262sub t105 :prototype($) ($a) { $a || "z" } 1263is prototype(\&t105), "\$"; 1264is eval("t105()"), undef; 1265like $@, qr/\ANot enough arguments for main::t105 /; 1266is eval("t105(0)"), "z"; 1267is eval("t105(456)"), 456; 1268is eval("t105(456, 789)"), undef; 1269like $@, qr/\AToo many arguments for main::t105 at \(eval \d+\) line 1, near/; 1270is eval("t105(456, 789, 987)"), undef; 1271like $@, qr/\AToo many arguments for main::t105 at \(eval \d+\) line 1, near/; 1272is $a, 123; 1273 1274sub t106 :prototype(@) ($a) { $a || "z" } 1275is prototype(\&t106), "\@"; 1276is eval("t106()"), undef; 1277like $@, _create_mismatch_regexp('main::t106', 0, 1); 1278is eval("t106(0)"), "z"; 1279is eval("t106(456)"), 456; 1280is eval("t106(456, 789)"), undef; 1281like $@, _create_mismatch_regexp('main::t106', 2, 1); 1282is eval("t106(456, 789, 987)"), undef; 1283like $@, _create_mismatch_regexp('main::t106', 3, 1); 1284is $a, 123; 1285 1286eval "#line 8 foo\nsub t107(\$a) :method { }"; 1287isnt $@, ""; 1288 1289eval "#line 8 foo\nsub t108 (\$a) :prototype(\$) { }"; 1290isnt $@, ""; 1291 1292sub t109 { } 1293is prototype(\&t109), undef; 1294is scalar(@{[ t109() ]}), 0; 1295is scalar(t109()), undef; 1296 1297sub t110 () { } 1298is prototype(\&t110), undef; 1299is scalar(@{[ t110() ]}), 0; 1300is scalar(t110()), undef; 1301 1302sub t111 ($a) { } 1303is prototype(\&t111), undef; 1304is scalar(@{[ t111(222) ]}), 0; 1305is scalar(t111(222)), undef; 1306 1307sub t112 ($) { } 1308is prototype(\&t112), undef; 1309is scalar(@{[ t112(222) ]}), 0; 1310is scalar(t112(222)), undef; 1311 1312sub t114 ($a = undef) { } 1313is prototype(\&t114), undef; 1314is scalar(@{[ t114() ]}), 0; 1315is scalar(t114()), undef; 1316is scalar(@{[ t114(333) ]}), 0; 1317is scalar(t114(333)), undef; 1318 1319sub t113 ($a = 222) { } 1320is prototype(\&t113), undef; 1321is scalar(@{[ t113() ]}), 0; 1322is scalar(t113()), undef; 1323is scalar(@{[ t113(333) ]}), 0; 1324is scalar(t113(333)), undef; 1325 1326sub t115 ($a = do { $z++; 222 }) { } 1327is prototype(\&t115), undef; 1328$z = 0; 1329is scalar(@{[ t115() ]}), 0; 1330is $z, 1; 1331is scalar(t115()), undef; 1332is $z, 2; 1333is scalar(@{[ t115(333) ]}), 0; 1334is scalar(t115(333)), undef; 1335is $z, 2; 1336 1337sub t116 (@a) { } 1338is prototype(\&t116), undef; 1339is scalar(@{[ t116() ]}), 0; 1340is scalar(t116()), undef; 1341is scalar(@{[ t116(333) ]}), 0; 1342is scalar(t116(333)), undef; 1343 1344sub t117 (%a) { } 1345is prototype(\&t117), undef; 1346is scalar(@{[ t117() ]}), 0; 1347is scalar(t117()), undef; 1348is scalar(@{[ t117(333, 444) ]}), 0; 1349is scalar(t117(333, 444)), undef; 1350 1351sub t145 ($=3) { } 1352is 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 1519package T200 { 1520 sub foo ($x) {} 1521 *t201 = sub ($x) {} 1522} 1523*t202 = sub ($x) {}; 1524my $t203 = sub ($x) {}; 1525*t204 = *T200::foo; 1526*t205 = \&T200::foo; 1527 1528eval { T200::foo() }; 1529like($@, qr/^Too few arguments for subroutine 'T200::foo'/); 1530eval { T200::t201() }; 1531like($@, qr/^Too few arguments for subroutine 'T200::__ANON__'/); 1532eval { t202() }; 1533like($@, qr/^Too few arguments for subroutine 'main::__ANON__'/); 1534eval { $t203->() }; 1535like($@, qr/^Too few arguments for subroutine 'main::__ANON__'/); 1536eval { t204() }; 1537like($@, qr/^Too few arguments for subroutine 'T200::foo'/); 1538eval { t205() }; 1539like($@, 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 1545eval "sub (\x80"; 1546like $@, qr/A signature parameter must start with/, "RT #130661"; 1547 1548 1549 1550use File::Spec::Functions; 1551my $keywords_file = catfile(updir,'regen','keywords.pl'); 1552open my $kh, $keywords_file 1553 or die "$0 cannot open $keywords_file: $!"; 1554while(<$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 1716SKIP: { 1717 skip_if_miniperl("miniperl can't load attributes.pm", 1); 1718 1719 # GH #21158 1720 # The :baz attribute is unrecognised but in the current implementation that 1721 # is only checked at runtime, and we never invoke the function so this 1722 # should be fine. 1723 ok(defined eval 'sub gh21158 ($x) { my $bar :baz; } "ok"', 1724 'Signatured subroutine permits attributed scalar') or 1725 diag("Error was $@"); 1726} 1727 1728done_testing; 1729 17301; 1731