This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Add 'indirect' feature that can be turned off to disable indirect object syntax
[perl5.git] / lib / B / Deparse.t
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 64ff49c..07c9150 100644 (file)
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -565,7 +565,7 @@ is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
 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}/;
 ####
@@ -1039,14 +1039,13 @@ my $b = \{};
 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 ($_ == 3) { continue; }
-    whereis ('quux') { continue; }
-    0;
+    when ('bar') { continue; }
+    when ($_ ~~ 'quux') { continue; }
+    default { 0; }
 }
 ####
 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
@@ -1439,11 +1438,48 @@ s/X//r;
 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;
@@ -1528,13 +1564,12 @@ $a[0] = 1;
 CORE::state $x;
 CORE::say $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1547,13 +1582,12 @@ use 1;
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1561,13 +1595,12 @@ CORE::evalbytes '';
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1580,13 +1613,12 @@ use 1;
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1596,13 +1628,12 @@ use feature ':default';
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1610,6 +1641,7 @@ CORE::evalbytes '';
 # 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;
@@ -1630,9 +1662,9 @@ my sub tr;
 my sub unless;
 my sub until;
 my sub use;
-my sub whereis;
-my sub whereso;
+my sub when;
 my sub while;
+CORE::default { die; }
 CORE::if ($1) { die; }
 CORE::if ($1) { die; }
 CORE::elsif ($1) { die; }
@@ -1654,8 +1686,7 @@ CORE::unless ($1) { die; }
 CORE::until ($1) { die; }
 die CORE::until $1;
 CORE::use strict;
-CORE::whereis (5) { die; }
-CORE::whereso ($1 ~~ $2) { die; }
+CORE::when ($1 ~~ $2) { die; }
 CORE::while ($1) { die; }
 die CORE::while $1;
 ####
@@ -1687,11 +1718,6 @@ my @x;
 @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
 /${(}/;
 /${|}/;
@@ -2018,7 +2044,7 @@ no warnings "experimental::lexical_subs";
 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 {
     
 }
@@ -2031,7 +2057,7 @@ no warnings 'experimental::lexical_subs';
 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 {
     
 }
@@ -2578,7 +2604,7 @@ $x++;
 no warnings;
 use feature 'signatures';
 my $x;
-sub ($a, $b) : prototype($$) {
+my $f = sub : prototype($$) ($a, $b) {
     $x++;
 }
 ;
@@ -2588,7 +2614,7 @@ $x++;
 no warnings;
 use feature 'signatures';
 my $x;
-sub ($a, $b) : prototype($$) lvalue {
+my $f = sub : prototype($$) lvalue ($a, $b) {
     $x++;
 }
 ;
@@ -2598,7 +2624,7 @@ $x++;
 no warnings;
 use feature 'signatures';
 my $x;
-sub ($a, $b) : lvalue method {
+my $f = sub : lvalue method ($a, $b) {
     $x++;
 }
 ;
@@ -3008,3 +3034,46 @@ 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'};
Unnamed repository; edit this file 'description' to name the repository.