diff options
| -rw-r--r-- | op.c | 12 | ||||
| -rw-r--r-- | pod/perldelta.pod | 16 | ||||
| -rw-r--r-- | pod/perlsub.pod | 18 | ||||
| -rw-r--r-- | t/comp/proto.t | 27 | ||||
| -rw-r--r-- | toke.c | 4 |
5 files changed, 72 insertions, 5 deletions
@@ -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; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index b82a0a1414..3d9e08a070 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -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 diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 149a8a71d1..c16db28937 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -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. diff --git a/t/comp/proto.t b/t/comp/proto.t index e785a9bdd6..e38ba11535 100644 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -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"; @@ -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 { |