This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add single-term prototype
authorDavid Golden <dagolden@cpan.org>
Mon, 13 Sep 2010 00:26:43 +0000 (20:26 -0400)
committerDavid Golden <dagolden@cpan.org>
Thu, 21 Oct 2010 13:23:58 +0000 (09:23 -0400)
The C<+> prototype is a special alternative to C<$> that will act like
C<\[@%]> when given a literal array or hash variable, but will otherwise
force scalar context on the argument.  This is useful for functions which
should accept either a literal array or an array reference as the argument:

    sub smartpush (+@) {
        my $aref = shift;
        die "Not an array or arrayref" unless ref $aref eq 'ARRAY';
        push @$aref, @_;
    }

When using the C<+> prototype, your function must check that the argument
is of an acceptable type.

op.c
pod/perldelta.pod
pod/perlsub.pod
t/comp/proto.t
toke.c

diff --git a/op.c b/op.c
index ac9a41e..469d48d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8735,6 +8735,18 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                }
                scalar(aop);
                break;
+           case '+':
+               proto++;
+               arg++;
+               if (o3->op_type == OP_RV2AV ||
+                   o3->op_type == OP_PADAV ||
+                   o3->op_type == OP_RV2HV ||
+                   o3->op_type == OP_PADHV
+               ) {
+                   goto wrapref;
+               }
+               scalar(aop);
+               break;
            case '[': case ']':
                goto oops;
                break;
index b82a0a1..3d9e08a 100644 (file)
@@ -28,6 +28,22 @@ here, but most should go in the L</Performance Enhancements> section.
 
 [ List each enhancement as a =head2 entry ]
 
+=head2 Single term prototype
+
+The C<+> prototype is a special alternative to C<$> that will act like
+C<\[@%]> when given a literal array or hash variable, but will otherwise
+force scalar context on the argument.  This is useful for functions which
+should accept either a literal array or an array reference as the argument:
+
+    sub smartpush (+@) {
+        my $aref = shift;
+        die "Not an array or arrayref" unless ref $aref eq 'ARRAY';
+        push @$aref, @_;
+    }
+
+When using the C<+> prototype, your function must check that the argument
+is of an acceptable type.
+
 =head1 Security
 
 XXX Any security-related notices go here.  In particular, any security
index 149a8a7..c16db28 100644 (file)
@@ -1100,8 +1100,8 @@ C<< my_function()->[0] >>. The value passed as part of C<@_> will be a
 reference to the actual argument given in the subroutine call,
 obtained by applying C<\> to that argument.
 
-You can also backslash several argument types simultaneously by using
-the C<\[]> notation:
+You can use the C<\[]> backslash group notation to specify more than one
+allowed argument type. For example:
 
     sub myref (\[$@%&*])
 
@@ -1136,6 +1136,20 @@ follows:
        ...
     }
 
+The C<+> prototype is a special alternative to C<$> that will act like
+C<\[@%]> when given a literal array or hash variable, but will otherwise
+force scalar context on the argument.  This is useful for functions which
+should accept either a literal array or an array reference as the argument:
+
+    sub smartpush (+@) {
+        my $aref = shift;
+        die "Not an array or arrayref" unless ref $aref eq 'ARRAY';
+        push @$aref, @_;
+    }
+
+When using the C<+> prototype, your function must check that the argument
+is of an acceptable type.
+
 A semicolon (C<;>) separates mandatory arguments from optional arguments.
 It is redundant before C<@> or C<%>, which gobble up everything else.
 
index e785a9b..e38ba11 100644 (file)
@@ -18,7 +18,7 @@ BEGIN {
 # strict
 use strict;
 
-print "1..160\n";
+print "1..168\n";
 
 my $i = 1;
 
@@ -546,6 +546,25 @@ sub sreftest (\$$) {
     sreftest $aelem[0], $i++;
 }
 
+# test single term
+sub lazy (+$$) {
+    print "not " unless @_ == 3 && ref $_[0] eq $_[1];
+    print "ok $_[2] - non container test\n";
+}
+sub quietlazy (+) { return shift(@_) }
+sub give_aref { [] }
+sub list_or_scalar { wantarray ? (1..10) : [] }
+{
+    my @multiarray = ("a".."z");
+    my %bighash = @multiarray;
+    lazy(\@multiarray, 'ARRAY', $i++);
+    lazy(\%bighash, 'HASH', $i++);
+    lazy({}, 'HASH', $i++);
+    lazy(give_aref, 'ARRAY', $i++);
+    lazy(3, '', $i++); # allowed by prototype, even if runtime error
+    lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context
+}
+
 # test prototypes when they are evaled and there is a syntax error
 # Byacc generates the string "syntax error".  Bison gives the
 # string "parse error".
@@ -676,3 +695,9 @@ print "ok ", $i++, "\n";
 print "not "
  unless eval 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1' or warn $@;
 print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto8 (+) {} uniproto8 $_, 1' or warn $@;
+print "ok ", $i++, "\n";
+print "not "
+ unless eval 'sub uniproto9 (;+) {} uniproto9 $_, 1' or warn $@;
+print "ok ", $i++, "\n";
diff --git a/toke.c b/toke.c
index ec2ac73..731c2b4 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -6523,7 +6523,7 @@ Perl_yylex(pTHX)
                            (
                                (
                                    *proto == '$' || *proto == '_'
-                                || *proto == '*'
+                                || *proto == '*' || *proto == '+'
                                )
                             && proto[1] == '\0'
                            )
@@ -7735,7 +7735,7 @@ Perl_yylex(pTHX)
                            if (warnillegalproto) {
                                if (must_be_last)
                                    proto_after_greedy_proto = TRUE;
-                               if (!strchr("$@%*;[]&\\_", *p)) {
+                               if (!strchr("$@%*;[]&\\_+", *p)) {
                                    bad_proto = TRUE;
                                }
                                else {