+map {
+ my $desc = 'map { 1 } 1';
+ is HERE, 1, "$desc : here" unless $^P;
+ is TOP, $top, "$desc : top";
+ is UP, $top, "$desc : up";
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, @warns) = $warn_catcher;
+ is SUB, undef, "$desc : sub";
+ is "@warns", 'subroutine', "$desc : sub warns";
+ local @warns;
+ is EVAL, undef, "$desc : eval";
+ is "@warns", 'eval', "$desc : eval warns";
+ local $SIG{__WARN__} = $old_sig_warn;
+} 1;
+
+grep {
+ my $desc = 'grep { 1 } 1';
+ is HERE, 1, "$desc : here" unless $^P;
+ is TOP, $top, "$desc : top";
+ is UP, $top, "$desc : up";
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, @warns) = $warn_catcher;
+ is SUB, undef, "$desc : sub";
+ is "@warns", 'subroutine', "$desc : sub warns";
+ local @warns;
+ is EVAL, undef, "$desc : eval";
+ is "@warns", 'eval', "$desc : eval warns";
+ local $SIG{__WARN__} = $old_sig_warn;
+} 1;
+
+my $var = 'a';
+$var =~ s[.][
+ my $desc = 'subst';
+ is HERE, 1, "$desc : here" unless $^P;
+ is TOP, $top, "$desc : top";
+ is UP, $top, "$desc : up";
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, @warns) = $warn_catcher;
+ is SUB, undef, "$desc : sub";
+ is "@warns", 'subroutine', "$desc : sub warns";
+ local @warns;
+ is EVAL, undef, "$desc : eval";
+ is "@warns", 'eval', "$desc : eval warns";
+ local $SIG{__WARN__} = $old_sig_warn;
+]e;
+
+$var = 'a';
+$var =~ s{.}{UP}e;
+is $var, $top, 'subst : fake block';
+
+$var = 'a';
+$var =~ s{.}{do { UP }}e;
+is $var, 1, 'subst : do block optimized away' unless $^P;
+
+$var = 'a';
+$var =~ s{.}{do { my $x; UP }}e;
+is $var, 1, 'subst : do block preserved' unless $^P;
+
+SKIP: {
+ my $skip_count = 4 * ($^P ? 4 : 5) + 4;
+ skip 'Perl 5.10 required to test given/when'
+ => $skip_count if "$]" < 5.010;
+ skip 'Not testing deprecated given/when on Perl 5.37.10 or later'
+ => $skip_count if "$]" >= 5.037010;
+
+ eval <<'TEST_GIVEN';
+ BEGIN {
+ if ("$]" >= 5.017_011) {
+ require warnings;
+ warnings->unimport('experimental::smartmatch');
+ }
+ }
+ use feature 'switch';
+ my $desc = 'given';
+ my $base = HERE;
+ given (1) {
+ is HERE, $base + 1, "$desc : here" unless $^P;
+ is TOP, $top, "$desc : top";
+ is UP, $base, "$desc : up";
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, @warns) = $warn_catcher;
+ is SUB, undef, "$desc : sub";
+ is "@warns", 'subroutine', "$desc : sub warns";
+ local $SIG{__WARN__} = $old_sig_warn;
+ is EVAL, $base, "$desc : eval";
+ }
+TEST_GIVEN
+ diag $@ if $@;
+
+ eval <<'TEST_GIVEN_WHEN';
+ BEGIN {
+ if ("$]" >= 5.017_011) {
+ require warnings;
+ warnings->unimport('experimental::smartmatch');
+ }
+ }
+ use feature 'switch';
+ my $desc = 'when in given';
+ my $base = HERE;
+ given (1) {
+ my $given = HERE;
+ when (1) {
+ is HERE, $base + 3, "$desc : here" unless $^P;
+ is TOP, $top, "$desc : top";
+ is UP, $given, "$desc : up";
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, @warns) = $warn_catcher;
+ is SUB, undef, "$desc : sub";
+ is "@warns", 'subroutine', "$desc : sub warns";
+ local $SIG{__WARN__} = $old_sig_warn;
+ is EVAL, $base, "$desc : eval";
+ }
+ }
+TEST_GIVEN_WHEN
+ diag $@ if $@;
+
+ eval <<'TEST_GIVEN_DEFAULT';
+ BEGIN {
+ if ("$]" >= 5.017_011) {
+ require warnings;
+ warnings->unimport('experimental::smartmatch');
+ }
+ }
+ use feature 'switch';
+ my $desc = 'default in given';
+ my $base = HERE;
+ given (1) {
+ my $given = HERE;
+ default {
+ is HERE, $base + 3, "$desc : here" unless $^P;
+ is TOP, $top, "$desc : top";
+ is UP, $given, "$desc : up";
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, @warns) = $warn_catcher;
+ is SUB, undef, "$desc : sub";
+ is "@warns", 'subroutine', "$desc : sub warns";
+ local $SIG{__WARN__} = $old_sig_warn;
+ is EVAL, $base, "$desc : eval";
+ }
+ }
+TEST_GIVEN_DEFAULT
+ diag $@ if $@;
+
+ eval <<'TEST_FOR_WHEN';
+ BEGIN {
+ if ("$]" >= 5.017_011) {
+ require warnings;
+ warnings->unimport('experimental::smartmatch');
+ }
+ }
+ use feature 'switch';
+ my $desc = 'when in for';
+ my $base = HERE;
+ for (1) {
+ my $loop = HERE;
+ when (1) {
+ is HERE, $base + 2, "$desc : here" unless $^P;
+ is TOP, $top, "$desc : top";
+ is UP, $loop, "$desc : up";
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, @warns) = $warn_catcher;
+ is SUB, undef, "$desc : sub";
+ is "@warns", 'subroutine', "$desc : sub warns";
+ local $SIG{__WARN__} = $old_sig_warn;
+ is EVAL, $base, "$desc : eval";
+ }
+ }
+TEST_FOR_WHEN
+ diag $@ if $@;
+}
+
+SKIP: {
+ skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
+
+ my $base = HERE;
+
+ do {
+ eval {
+ do {
+ sub {
+ eval q[
+ {
+ is HERE, $base + 6, 'mixed : here';
+ is TOP, $top, 'mixed : top';
+ is SUB, $base + 4, 'mixed : first sub';
+ is SUB(SUB), $base + 4, 'mixed : still first sub';
+ is EVAL, $base + 5, 'mixed : first eval';
+ is EVAL(EVAL), $base + 5, 'mixed : still first eval';
+ is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
+ }
+ ];
+ }->();
+ }
+ };
+ } while (0);
+}
+