use warnings;
use strict;
-my $tests = 49; # not counting those in the __DATA__ section
+my $tests = 52; # not counting those in the __DATA__ section
use B::Deparse;
my $deparse = B::Deparse->new();
qr'Use of uninitialized value',
'no warnings for undefined sub';
+is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+ prog => 'sub f { 1; } BEGIN { *g = \&f; }'),
+ "sub f {\n 1;\n}\nsub BEGIN {\n *g = \\&f;\n}\n",
+ "sub glob alias shouldn't impede emitting original sub";
+
+is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+ prog => 'package Foo; sub f { 1; } BEGIN { *g = \&f; }'),
+ "package Foo;\nsub f {\n 1;\n}\nsub BEGIN {\n *g = \\&f;\n}\n",
+ "sub glob alias outside main shouldn't impede emitting original sub";
+
+is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+ prog => 'package Foo; sub f { 1; } BEGIN { *Bar::f = \&f; }'),
+ "package Foo;\nsub f {\n 1;\n}\nsub BEGIN {\n *Bar::f = \\&f;\n}\n",
+ "sub glob alias in separate package shouldn't impede emitting original sub";
+
+
done_testing($tests);
__DATA__
-# TODO [perl #120950] This succeeds when run a 2nd time
+# [perl #120950] Previously on a 2nd instance succeeded
# y/uni/code/
tr/\x{345}/\x{370}/;
####
my $c = [];
my $d = \[];
####
-# SKIP ?$] < 5.010 && "smartmatch and given/whereso not implemented on this Perl version"
+# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
# CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
-# implicit smartmatch in given/whereso
+# implicit smartmatch in given/when
given ('foo') {
- whereso ('bar') { continue; }
- whereso ($_ ~~ 'quux') { continue; }
- 0;
+ when ('bar') { continue; }
+ when ($_ ~~ 'quux') { continue; }
+ default { 0; }
}
####
# conditions in elsifs (regression in change #33710 which fixed bug #37302)
use feature 'unicode_strings';
s/X//d;
####
-# all the flags (tr///)
-tr/X/Y/c;
-tr/X//d;
-tr/X//s;
-tr/X//r;
+# tr/// with all the flags: empty replacement
+tr/B-G//;
+tr/B-G//c;
+tr/B-G//d;
+tr/B-G//s;
+tr/B-G//cd;
+tr/B-G//ds;
+tr/B-G//cs;
+tr/B-G//cds;
+tr/B-G//r;
+####
+# tr/// with all the flags: short replacement
+tr/B-G/b/;
+tr/B-G/b/c;
+tr/B-G/b/d;
+tr/B-G/b/s;
+tr/B-G/b/cd;
+tr/B-G/b/ds;
+tr/B-G/b/cs;
+tr/B-G/b/cds;
+tr/B-G/b/r;
+####
+# tr/// with all the flags: equal length replacement
+tr/B-G/b-g/;
+tr/B-G/b-g/c;
+tr/B-G/b-g/s;
+tr/B-G/b-g/cs;
+tr/B-G/b-g/r;
+####
+# tr with extended table (/c)
+tr/\000-\375/AB/c;
+tr/\000-\375/A-C/c;
+tr/\000-\375/A-D/c;
+tr/\000-\375/A-I/c;
+tr/\000-\375/AB/cd;
+tr/\000-\375/A-C/cd;
+tr/\000-\375/A-D/cd;
+tr/\000-\375/A-I/cd;
+tr/\000-\375/AB/cds;
+tr/\000-\375/A-C/cds;
+tr/\000-\375/A-D/cds;
+tr/\000-\375/A-I/cds;
####
# [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
s/foo/\(3);/eg;
CORE::state $x;
CORE::say $x;
CORE::given ($x) {
- CORE::whereso (3) {
+ CORE::when (3) {
continue;
}
- next;
+ CORE::default {
+ CORE::break;
+ }
}
CORE::evalbytes '';
() = CORE::__SUB__;
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
- CORE::whereso (3) {
+ CORE::when (3) {
continue;
}
- next;
+ CORE::default {
+ CORE::break;
+ }
}
CORE::evalbytes '';
() = CORE::__SUB__;
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
- CORE::whereso (3) {
+ CORE::when (3) {
continue;
}
- next;
+ CORE::default {
+ CORE::break;
+ }
}
CORE::evalbytes '';
() = CORE::__SUB__;
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
- CORE::whereso (3) {
+ CORE::when (3) {
continue;
}
- next;
+ CORE::default {
+ CORE::break;
+ }
}
CORE::evalbytes '';
() = CORE::__SUB__;
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
- CORE::whereso (3) {
+ CORE::when (3) {
continue;
}
- next;
+ CORE::default {
+ CORE::break;
+ }
}
CORE::evalbytes '';
() = CORE::__SUB__;
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical subroutines and keywords of the same name
# CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental';
+my sub default;
my sub else;
my sub elsif;
my sub for;
my sub unless;
my sub until;
my sub use;
-my sub whereso;
+my sub when;
my sub while;
+CORE::default { die; }
CORE::if ($1) { die; }
CORE::if ($1) { die; }
CORE::elsif ($1) { die; }
CORE::until ($1) { die; }
die CORE::until $1;
CORE::use strict;
-CORE::whereso ($1 ~~ $2) { die; }
+CORE::when ($1 ~~ $2) { die; }
CORE::while ($1) { die; }
die CORE::while $1;
####
@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
@x = ($#{;}, $#{:}, $#{1}), $#_;
####
-# ${#} interpolated
-# It's a known TODO that warnings are deparsed as bits, not textually.
-no warnings;
-() = "${#}a";
-####
# [perl #86060] $( $| $) in regexps need braces
/${(}/;
/${|}/;
my sub f {}
print f();
>>>>
-BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
+BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55\x55"}
my sub f {
}
state sub f {}
print f();
>>>>
-BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
+BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55\x55"}
state sub f {
}
no warnings;
use feature 'signatures';
my $x;
-sub ($a, $b) : prototype($$) {
+my $f = sub : prototype($$) ($a, $b) {
$x++;
}
;
no warnings;
use feature 'signatures';
my $x;
-sub ($a, $b) : prototype($$) lvalue {
+my $f = sub : prototype($$) lvalue ($a, $b) {
$x++;
}
;
no warnings;
use feature 'signatures';
my $x;
-sub ($a, $b) : lvalue method {
+my $f = sub : lvalue method ($a, $b) {
$x++;
}
;
print exists &main::foo;
print exists &{foo};
print exists &main::bar;
+# precedence of optimised-away 'keys' (OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS)
+my($r1, %h1, $res);
+our($r2, %h2);
+$res = keys %h1;
+$res = keys %h2;
+$res = keys %$r1;
+$res = keys %$r2;
+$res = keys(%h1) / 2 - 1;
+$res = keys(%h2) / 2 - 1;
+$res = keys(%$r1) / 2 - 1;
+$res = keys(%$r2) / 2 - 1;
+####
+# ditto in presence of sub keys {}
+# CONTEXT sub keys {}
+no warnings;
+my($r1, %h1, $res);
+our($r2, %h2);
+CORE::keys %h1;
+CORE::keys(%h1) / 2;
+$res = CORE::keys %h1;
+$res = CORE::keys %h2;
+$res = CORE::keys %$r1;
+$res = CORE::keys %$r2;
+$res = CORE::keys(%h1) / 2 - 1;
+$res = CORE::keys(%h2) / 2 - 1;
+$res = CORE::keys(%$r1) / 2 - 1;
+$res = CORE::keys(%$r2) / 2 - 1;
+####
+# concat: STACKED: ambiguity between .= and optimised nested
+my($a, $b);
+$b = $a . $a . $a;
+(($a .= $a) .= $a) .= $a;
+####
+# multiconcat: $$ within string
+my($a, $x);
+$x = "${$}abc";
+$x = "\$$a";
+####
+# single state aggregate assignment
+# CONTEXT use feature "state";
+state @a = (1, 2, 3);
+state %h = ('a', 1, 'b', 2);
+####
+# state var with attribute
+# CONTEXT use feature "state";
+state $x :shared;
+state $y :shared = 1;
+state @a :shared;
+state @b :shared = (1, 2);
+state %h :shared;
+state %i :shared = ('a', 1, 'b', 2);
+####
+# \our @a shouldn't be a list
+my $r = \our @a;
+my(@l) = \our((@b));
+@l = \our(@c, @d);
+####
+# postfix $#
+our(@b, $s, $l);
+$l = (\my @a)->$#*;
+(\@b)->$#* = 1;
+++(\my @c)->$#*;
+$l = $#a;
+$#a = 1;
+$l = $#b;
+$#b = 1;
+my $r;
+$l = $r->$#*;
+$r->$#* = 1;
+$l = $#{@$r;};
+$#{$r;} = 1;
+$l = $s->$#*;
+$s->$#* = 1;
+$l = $#{@$s;};
+$#{$s;} = 1;
+####
+# TODO doesn't preserve backslash
+my @a;
+my $s = "$a[0]\[1]";
+####
+# GH #17301 aux_list() sometimes returned wrong #args
+my($r, $h);
+$r = $h->{'i'};
+$r = $h->{'i'}{'j'};
+$r = $h->{'i'}{'j'}{'k'};
+$r = $h->{'i'}{'j'}{'k'}{'l'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'};
+$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'}{'t'};