From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Wed, 9 Jan 2002 23:24:32 +0000 (+0100)
Subject: B::Deparse : support for \[...] prototypes
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2ae48fff688c68e6afa331ca1e3b8b5e02043968;p=p5sagit%2Fp5-mst-13.2.git

B::Deparse : support for \[...] prototypes
Message-ID: <20020109232432.A692@rafael>

p4raw-id: //depot/perl@14159
---

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 988ad92..a6644fb 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -21,6 +21,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber cstring
 	 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
 $VERSION = 0.62;
 use strict;
+use vars qw/$AUTOLOAD/;
 use warnings ();
 
 # Changes between 0.50 and 0.51:
@@ -951,89 +952,13 @@ sub maybe_my {
 
 # pp_padany -- does not exist after parsing
 
-sub pp_enter { # see also leave
-    carp "unexpected OP_ENTER";
-    return "XXX";
-}
-
-sub pp_pushmark { # see also list
-    carp "unexpected OP_PUSHMARK";
-    return "XXX";
-}
-
-sub pp_leavesub { # see also deparse_sub
-    carp "unexpected OP_LEAVESUB";
-    return "XXX";
-}
-
-sub pp_leavewrite { # see also deparse_format
-    carp "unexpected OP_LEAVEWRITE";
-    return "XXX";
-}
-
-sub pp_method { # see also entersub
-    carp "unexpected OP_METHOD";
-    return "XXX";
-}
-
-sub pp_regcmaybe { # see also regcomp
-    carp "unexpected OP_REGCMAYBE";
-    return "XXX";
-}
-
-sub pp_regcreset { # see also regcomp
-    carp "unexpected OP_REGCRESET";
-    return "XXX";
-}
-
-sub pp_substcont { # see also subst
-    carp "unexpected OP_SUBSTCONT";
-    return "XXX";
-}
-
-sub pp_grepstart { # see also grepwhile
-    carp "unexpected OP_GREPSTART";
-    return "XXX";
-}
-
-sub pp_mapstart { # see also mapwhile
-    carp "unexpected OP_MAPSTART";
-    return "XXX";
-}
-
-sub pp_method_named {
-    carp "unexpected OP_METHOD_NAMED";
-    return "XXX";
-}
-
-sub pp_flip { # see also flop
-    carp "unexpected OP_FLIP";
-    return "XXX";
-}
-
-sub pp_iter { # see also leaveloop
-    carp "unexpected OP_ITER";
-    return "XXX";
-}
-
-sub pp_enteriter { # see also leaveloop
-    carp "unexpected OP_ENTERITER";
-    return "XXX";
-}
-
-sub pp_enterloop { # see also leaveloop
-    carp "unexpected OP_ENTERLOOP";
-    return "XXX";
-}
-
-sub pp_leaveeval { # see also entereval
-    carp "unexpected OP_LEAVEEVAL";
-    return "XXX";
-}
-
-sub pp_entertry { # see also leavetry
-    carp "unexpected OP_ENTERTRY";
-    return "XXX";
+sub AUTOLOAD {
+    if ($AUTOLOAD =~ s/^.*::pp_//) {
+	warn "unexpected OP_".uc $AUTOLOAD;
+	return "XXX";
+    } else {
+	die "Undefined subroutine $AUTOLOAD called";
+    }
 }
 
 # $root should be the op which represents the root of whatever
@@ -2859,9 +2784,9 @@ sub check_proto {
     my $doneok = 0;
     my @reals;
     # An unbackslashed @ or % gobbles up the rest of the args
-    $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
+    1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
     while ($proto) {
-	$proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
+	$proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
 	my $chr = $1;
 	if ($chr eq "") {
 	    return "&" if @args;
@@ -2899,19 +2824,21 @@ sub check_proto {
 		      return "&";
 		  }
 	    } elsif (substr($chr, 0, 1) eq "\\") {
-		$chr = substr($chr, 1);
+		$chr =~ tr/\\[]//d;
 		if ($arg->name =~ /^s?refgen$/ and
 		    !null($real = $arg->first) and
-		    ($chr eq "\$" && is_scalar($real->first)
-		     or ($chr eq "\@"
+		    ($chr =~ /\$/ && is_scalar($real->first)
+		     or ($chr =~ /@/
+			 && class($real->first->sibling) ne 'NULL'
 			 && $real->first->sibling->name
 			 =~ /^(rv2|pad)av$/)
-		     or ($chr eq "%"
+		     or ($chr =~ /%/
+			 && class($real->first->sibling) ne 'NULL'
 			 && $real->first->sibling->name
 			 =~ /^(rv2|pad)hv$/)
-		     #or ($chr eq "&" # This doesn't work
+		     #or ($chr =~ /&/ # This doesn't work
 		     #   && $real->first->name eq "rv2cv")
-		     or ($chr eq "*"
+		     or ($chr =~ /\*/
 			 && $real->first->name eq "rv2gv")))
 		  {
 		      push @reals, $self->deparse($real, 6);