In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c035a075a240f10383292128a8d3f3746c4ac857?hp=9061a8f72941979d02cbccb5cb18a2034813b6a7>
- Log ----------------------------------------------------------------- commit c035a075a240f10383292128a8d3f3746c4ac857 Author: David Golden <[email protected]> Date: Sun Sep 12 20:26:43 2010 -0400 Add 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. ----------------------------------------------------------------------- Summary of changes: op.c | 12 ++++++++++++ pod/perldelta.pod | 16 ++++++++++++++++ pod/perlsub.pod | 18 ++++++++++++++++-- t/comp/proto.t | 27 ++++++++++++++++++++++++++- toke.c | 4 ++-- 5 files changed, 72 insertions(+), 5 deletions(-) diff --git a/op.c b/op.c index ac9a41e..469d48d 100644 --- 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; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index b82a0a1..3d9e08a 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 149a8a7..c16db28 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 e785a9b..e38ba11 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"; diff --git a/toke.c b/toke.c index ec2ac73..731c2b4 100644 --- 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 { -- Perl5 Master Repository
