[perl.git] branch blead, updated. v5.13.3-185-g649d02d

[Rafael Garcia-Suarez]

In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/649d02de73e8b1b9c262cff3c412f942cc4e7bdd?hp=beae72eec1a5f0babdb94514be158b0d599d674a>

- Log -----------------------------------------------------------------
commit 649d02de73e8b1b9c262cff3c412f942cc4e7bdd
Author: Father Chrysostomos <spr...@cpan.org>
Date:   Wed Aug 11 11:53:08 2010 +0200

    [perl #75904] \$ prototype does not make a unary function
    
    This fixes this problem :
      $ perl -le' sub foo($) { print "foo" }; foo $_, exit'
      foo
      $ perl -le' sub foo(\$) { print "foo" }; foo $_, exit'
      Too many arguments for main::foo at -e line 1, at EOF
      Execution of -e aborted due to compilation errors.
    
    for all those prototypes:
      *
      \sigil
      \[...]
      ;$
      ;*
      ;\sigil
      ;\[...]
-----------------------------------------------------------------------

Summary of changes:
 t/comp/proto.t |   27 ++++++++++++++++++++++++++-
 toke.c         |   21 +++++++++++++++++++--
 2 files changed, 45 insertions(+), 3 deletions(-)

diff --git a/t/comp/proto.t b/t/comp/proto.t
index 734a68b..e785a9b 100644
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -18,7 +18,7 @@ BEGIN {
 # strict
 use strict;
 
-print "1..153\n";
+print "1..160\n";
 
 my $i = 1;
 
@@ -651,3 +651,28 @@ print "ok ", $i++, "\n";
 eval 'sub bug (\...@]) {  } my $array = [0 .. 1]; bug %$array;';
 print "not " unless $@ =~ /Not a HASH reference/;
 print "ok ", $i++, "\n";
+
+# [perl #75904]
+# Test that the following prototypes make subs parse as unary functions:
+#  * \sigil \[...] ;$ ;* ;\sigil ;\[...]
+print "not "
+ unless eval 'sub uniproto1 (*) {} uniproto1 $_, 1' or warn $@;
+print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto2 (\$) {} uniproto2 $_, 1' or warn $@;
+print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1' or warn $@;
+print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto4 (;$) {} uniproto4 $_, 1' or warn $@;
+print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto5 (;*) {} uniproto5 $_, 1' or warn $@;
+print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto6 (;\@) {} uniproto6 @_, 1' or warn $@;
+print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto7 (;\...@]) {} uniproto7 @_, 1' or warn $@;
+print "ok ", $i++, "\n";
diff --git a/toke.c b/toke.c
index 455f977..544cd1a 100644
--- a/toke.c
+++ b/toke.c
@@ -6495,10 +6495,27 @@ Perl_yylex(pTHX)
                        const char *proto = SvPV_const(MUTABLE_SV(cv), 
protolen);
                        if (!protolen)
                            TERM(FUNC0SUB);
-                       if ((*proto == '$' || *proto == '_') && proto[1] == 
'\0')
-                           OPERATOR(UNIOPSUB);
                        while (*proto == ';')
                            proto++;
+                       if (
+                           (
+                               (
+                                   *proto == '$' || *proto == '_'
+                                || *proto == '*'
+                               )
+                            && proto[1] == '\0'
+                           )
+                        || (
+                            *proto == '\\' && proto[1] && proto[2] == '\0'
+                           )
+                       )
+                           OPERATOR(UNIOPSUB);
+                       if (*proto == '\\' && proto[1] == '[') {
+                           const char *p = proto + 2;
+                           while(*p && *p != ']')
+                               ++p;
+                           if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
+                       }
                        if (*proto == '&' && *s == '{') {
                            if (PL_curstash)
                                sv_setpvs(PL_subname, "__ANON__");

--
Perl5 Master Repository