diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 3 | ||||
| -rw-r--r-- | ext/attributes/attributes.pm | 15 | ||||
| -rw-r--r-- | ext/attributes/attributes.xs | 23 | ||||
| -rw-r--r-- | op.c | 114 | ||||
| -rw-r--r-- | pod/perldelta.pod | 13 | ||||
| -rw-r--r-- | pod/perldiag.pod | 13 | ||||
| -rw-r--r-- | pod/perlsub.pod | 4 | ||||
| -rw-r--r-- | proto.h | 7 | ||||
| -rw-r--r-- | t/op/attrproto.t | 139 |
11 files changed, 323 insertions, 12 deletions
@@ -5189,6 +5189,7 @@ t/op/array_base.t Tests for the remnant of $[ t/op/array.t See if array operations work t/op/assignwarn.t See if OP= operators warn correctly for undef targets t/op/attrhand.t See if attribute handlers work +t/op/attrproto.t See if the prototype attribute works t/op/attrs.t See if attributes on declarations work t/op/auto.t See if autoincrement et all work t/op/avhv.t See if pseudo-hashes work @@ -300,7 +300,7 @@ p |SV * |core_prototype |NULLOK SV *sv|NN const char *name \ p |OP * |coresub_op |NN SV *const coreargssv|const int code \ |const int opnum : Used in sv.c -p |void |cv_ckproto_len_flags |NN const CV* cv|NULLOK const GV* gv\ +EMXp |void |cv_ckproto_len_flags |NN const CV* cv|NULLOK const GV* gv\ |NULLOK const char* p|const STRLEN len \ |const U32 flags : Used in pp.c and pp_sys.c @@ -862,6 +862,7 @@ poX |OP* |op_lvalue_flags|NULLOK OP* o|I32 type|U32 flags p |void |finalize_optree |NN OP* o #if defined(PERL_IN_OP_C) s |void |finalize_op |NN OP* o +s |void |move_proto_attr|NN OP **proto|NN OP **attrs|NN const GV *name #endif : Used in op.c and pp_sys.c p |int |mode_from_discipline|NULLOK const char* s|STRLEN len @@ -855,6 +855,7 @@ #if defined(PERL_CORE) || defined(PERL_EXT) #define av_reify(a) Perl_av_reify(aTHX_ a) #define current_re_engine() Perl_current_re_engine(aTHX) +#define cv_ckproto_len_flags(a,b,c,d,e) Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e) #define mg_find_mglob(a) Perl_mg_find_mglob(aTHX_ a) #define op_clear(a) Perl_op_clear(aTHX_ a) #define qerror(a) Perl_qerror(aTHX_ a) @@ -1082,7 +1083,6 @@ #define create_eval_scope(a) Perl_create_eval_scope(aTHX_ a) #define croak_no_mem Perl_croak_no_mem #define croak_popstack Perl_croak_popstack -#define cv_ckproto_len_flags(a,b,c,d,e) Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e) #define cv_clone_into(a,b) Perl_cv_clone_into(aTHX_ a,b) #define cv_const_sv_or_av(a) Perl_cv_const_sv_or_av(aTHX_ a) #define cv_forget_slab(a) Perl_cv_forget_slab(aTHX_ a) @@ -1457,6 +1457,7 @@ #define listkids(a) S_listkids(aTHX_ a) #define looks_like_bool(a) S_looks_like_bool(aTHX_ a) #define modkids(a,b) S_modkids(aTHX_ a,b) +#define move_proto_attr(a,b,c) S_move_proto_attr(aTHX_ a,b,c) #define my_kid(a,b,c) S_my_kid(aTHX_ a,b,c) #define newDEFSVOP() S_newDEFSVOP(aTHX) #define newGIVWHENOP(a,b,c,d,e) S_newGIVWHENOP(aTHX_ a,b,c,d,e) diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index 5a656a6923..7c3c0b0247 100644 --- a/ext/attributes/attributes.pm +++ b/ext/attributes/attributes.pm @@ -1,6 +1,6 @@ package attributes; -our $VERSION = 0.21; +our $VERSION = 0.22; @EXPORT_OK = qw(get reftype); @EXPORT = (); @@ -238,6 +238,19 @@ Indicates that the referenced subroutine is a method. A subroutine so marked will not trigger the "Ambiguous call resolved as CORE::%s" warning. +=item prototype(..) + +The "prototype" attribute is an alternate means of specifying a prototype +on a sub. The desired prototype is within the parens. + +The prototype from the attribute is assigned to the sub immediately after +the prototype from the sub, which means that if both are declared at the +same time, the traditionally defined prototype is ignored. In other words, +C<sub foo($$) : prototype(@) {}> is indistinguishable from C<sub foo(@){}>. + +If illegalproto warnings are enabled, the prototype declared inside this +attribute will be sanity checked at compile time. + =item locked The "locked" attribute is deprecated, and has no effect in 5.10.0 and later. diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs index d39b77a4f4..dbb644d066 100644 --- a/ext/attributes/attributes.xs +++ b/ext/attributes/attributes.xs @@ -71,6 +71,29 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) break; } break; + default: + if (len > 10 && memEQ(name, "prototype(", 10)) { + SV * proto = newSVpvn(name+10,len-11); + HEK *const hek = CvNAME_HEK((CV *)sv); + SV *subname; + if (name[len-1] != ')') + Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list"); + if (hek) + subname = sv_2mortal(newSVhek(hek)); + else + subname=(SV *)CvGV((const CV *)sv); + if (ckWARN(WARN_ILLEGALPROTO)) + Perl_validate_proto(aTHX_ subname, proto, TRUE); + Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv, + (const GV *)subname, + name+10, + len-11, + SvUTF8(attr)); + sv_setpvn(MUTABLE_SV(sv), name+10, len-11); + if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv)); + continue; + } + break; } break; default: @@ -2668,6 +2668,98 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, attrs))); } +STATIC void +S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) +{ + OP *new_proto = NULL; + STRLEN pvlen; + char *pv; + OP *o; + + PERL_ARGS_ASSERT_MOVE_PROTO_ATTR; + + if (!*attrs) + return; + + o = *attrs; + if (o->op_type == OP_CONST) { + pv = SvPV(cSVOPo_sv, pvlen); + if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { + SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); + SV ** const tmpo = cSVOPx_svp(o); + SvREFCNT_dec(cSVOPo_sv); + *tmpo = tmpsv; + new_proto = o; + *attrs = NULL; + } + } else if (o->op_type == OP_LIST) { + OP * lasto = NULL; + assert(o->op_flags & OPf_KIDS); + assert(cLISTOPo->op_first->op_type == OP_PUSHMARK); + /* Counting on the first op to hit the lasto = o line */ + for (o = cLISTOPo->op_first; o; o=o->op_sibling) { + if (o->op_type == OP_CONST) { + pv = SvPV(cSVOPo_sv, pvlen); + if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { + SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); + SV ** const tmpo = cSVOPx_svp(o); + SvREFCNT_dec(cSVOPo_sv); + *tmpo = tmpsv; + if (new_proto && ckWARN(WARN_MISC)) { + STRLEN new_len; + const char * newp = SvPV(cSVOPo_sv, new_len); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub", + UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp)); + op_free(new_proto); + } + else if (new_proto) + op_free(new_proto); + new_proto = o; + lasto->op_sibling = o->op_sibling; + continue; + } + } + lasto = o; + } + /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs + would get pulled in with no real need */ + if (!cLISTOPx(*attrs)->op_first->op_sibling) { + op_free(*attrs); + *attrs = NULL; + } + } + + if (new_proto) { + SV *svname; + if (isGV(name)) { + svname = sv_newmortal(); + gv_efullname3(svname, name, NULL); + } + else if (SvPOK(name) && *SvPVX((SV *)name) == '&') + svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP); + else + svname = (SV *)name; + if (ckWARN(WARN_ILLEGALPROTO)) + (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE); + if (*proto && ckWARN(WARN_PROTOTYPE)) { + STRLEN old_len, new_len; + const char * oldp = SvPV(cSVOPx_sv(*proto), old_len); + const char * newp = SvPV(cSVOPx_sv(new_proto), new_len); + + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), + "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'" + " in %"SVf, + UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp), + UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), + SVfARG(svname)); + } + if (*proto) + op_free(*proto); + *proto = new_proto; + } +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { @@ -7161,6 +7253,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; spot = (CV **)svspot; + if (!(PL_parser && PL_parser->error_count)) + move_proto_attr(&proto, &attrs, (GV *)name); + if (proto) { assert(proto->op_type == OP_CONST); ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); @@ -7502,14 +7597,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OPSLAB *slab = NULL; #endif - if (proto) { - assert(proto->op_type == OP_CONST); - ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); - ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); - } - else - ps = NULL; - if (o_is_gv) { gv = (GV*)o; o = NULL; @@ -7532,6 +7619,17 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, has_name = FALSE; } + if (!ec) + move_proto_attr(&proto, &attrs, gv); + + if (proto) { + assert(proto->op_type == OP_CONST); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); + } + else + ps = NULL; + if (!PL_madskills) { if (o) SAVEFREEOP(o); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 3dcf78f216..381f14586b 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -59,6 +59,13 @@ they are suppressed. For more information, consult L<the Postfix Dereference Syntax section of perlref|perlref/Postfix Dereference Syntax>. +=head2 C<sub>s now take a C<prototype> attribute + +When declaring or defining a C<sub>, the prototype can now be specified +inside of a C<prototype> attribute instead of in parens following the name. + +For example, C<sub foo($$){}> could be rewritten as C<sub foo : prototype($$){}> + =head1 Security XXX Any security-related notices go here. In particular, any security @@ -315,6 +322,12 @@ L<warnings> has been upgraded from version 1.19 to 1.20. The new warnings category C<experimental::postderef> has been added. +=item * + +L<attributes> has been upgraded from version 0.21 to 0.22 + +Added support for the C<prototype> attribute. + =back =head2 Removed Modules and Pragmata diff --git a/pod/perldiag.pod b/pod/perldiag.pod index da4dfbd67a..6a42e08cf1 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -366,6 +366,12 @@ the "unique" attribute on an array, hash or scalar reference. The :unique attribute has had no effect since Perl 5.8.8, and will be removed in a future release of Perl 5. +=item Attribute prototype(%s) discards earlier prototype attribute in same sub + +(W misc) A sub was declared as sub foo : prototype(A) : prototype(B) {}, for +example. Since each sub can only have one prototype, the earlier +declaration(s) are discarded while the last one is applied. + =item av_reify called on tied array (S debugging) This indicates that something went wrong and Perl got I<very> @@ -4378,6 +4384,13 @@ declared or defined with a different function prototype. (F) You've omitted the closing parenthesis in a function prototype definition. +=item Prototype '%s' overridden by attribute 'prototype(%s)' in %s + +(W prototype) A prototype was declared in both the parentheses after +the sub name and via the prototype attribute. The prototype in +parentheses is useless, since it will be replaced by the prototype +from the attribute before it's ever used. + =item \p{} uses Unicode rules, not locale rules (W) You compiled a regular expression that contained a Unicode property diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 2b4b35b96b..2a9e0a838f 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -1189,7 +1189,9 @@ Notice to pass back just the bare *FH, not its reference. X<prototype> X<subroutine, prototype> Perl supports a very limited kind of compile-time argument checking -using function prototyping. If you declare +using function prototyping. This can be declared in either the PROTO +section or with a L<prototype attribute|attributes/Built-in Attributes>. +If you declare sub mypush (+@) @@ -6019,6 +6019,13 @@ STATIC bool S_looks_like_bool(pTHX_ const OP* o) assert(o) STATIC OP* S_modkids(pTHX_ OP *o, I32 type); +STATIC void S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV *name) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_MOVE_PROTO_ATTR \ + assert(proto); assert(attrs); assert(name) + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_MY_KID \ diff --git a/t/op/attrproto.t b/t/op/attrproto.t new file mode 100644 index 0000000000..13ce10730f --- /dev/null +++ b/t/op/attrproto.t @@ -0,0 +1,139 @@ +#!./perl + +# Testing the : prototype(..) attribute + + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; + skip_all_if_miniperl("miniperl can't load attributes"); +} +use warnings; + +plan tests => 48; + +my @warnings; +my ($attrs, $ret) = ("", ""); +sub Q::MODIFY_CODE_ATTRIBUTES { my ($name, $ref, @attrs) = @_; $attrs = "@attrs";return;} +$SIG{__WARN__} = sub { push @warnings, shift;}; + +$ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;'; +is $ret, "bad", "Prototype is set to \"bad\""; +is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; +like shift @warnings, "Illegal character in prototype for Q::A : bar", + "First warning is bad prototype - bar"; +like shift @warnings, "Illegal character in prototype for Q::A : bad", + "Second warning is bad prototype - bad"; +like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A', + "Third warning is Prototype overridden"; +is @warnings, 0, "No more warnings"; + +# The override warning should not be hidden by no warnings (similar to prototype changed warnings) +{ + no warnings 'illegalproto'; + $ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;'; + is $ret, "bad", "Prototype is set to \"bad\""; + is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; + like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B', + "First warning is Prototype overridden"; + is @warnings, 0, "No more warnings"; +} + +# Redeclaring a sub with a prototype attribute ignores it +$ret = eval 'package Q; sub B(ignored) : prototype(baz) : dummy3; prototype \&B;'; +is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype"; +is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; +like shift @warnings, "Illegal character in prototype for Q::B : ignored", + "Shifting off warning for the 'ignored' prototype"; +like shift @warnings, "Illegal character in prototype for Q::B : baz", + "Attempting to redeclare triggers Illegal character warning"; +like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B', + "Shifting off Prototype overridden warning"; +like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)', + "Attempting to redeclare triggers prototype mismatch warning against first prototype"; +is @warnings, 0, "No more warnings"; + +# Confirm redifining with a prototype attribute takes it +$ret = eval 'package Q; sub B(ignored) : prototype(baz) dummy4 {5}; prototype \&B;'; +is $ret, "baz", "Redefining with prototype(..) changes the prototype"; +is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; +is &Q::B, 5, "Function successfully redefined"; +like shift @warnings, "Illegal character in prototype for Q::B : ignored", + "Attempting to redeclare triggers Illegal character warning"; +like shift @warnings, "Illegal character in prototype for Q::B : baz", + "Attempting to redeclare triggers Illegal character warning"; +like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B', + "Shifting off Prototype overridden warning"; +like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)', + "Attempting to redeclare triggers prototype mismatch warning"; +like shift @warnings, 'Subroutine B redefined', + "Only other warning is subroutine redefinition"; +is @warnings, 0, "No more warnings"; + +# Multiple prototype declarations only takes the last one +$ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;'; +is $ret, "\$\$\$", "Last prototype declared wins"; +like shift @warnings, 'Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub', + "Multiple prototype declarations warns"; +is @warnings, 0, "No more warnings"; + +# Use attributes +eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";'; +$ret = prototype \&Q::B; +is $ret, "new", "use attributes also sets the prototype"; +like shift @warnings, 'Prototype mismatch: sub Q::B \(baz\) vs \(new\)', + "Prototype mismatch warning triggered"; +is @warnings, 0, "No more warnings"; + +eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";'; +$ret = prototype \&Q::B; +is $ret, "new", "A malformed prototype doesn't reset it"; +like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked"; +is @warnings, 0, "Malformed prototype isn't just a warning"; + +eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";'; +$ret = prototype \&Q::B; +is $ret, "new", "A malformed prototype doesn't reset it"; +like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked"; +is @warnings, 0, "Malformed prototype isn't just a warning"; + +# Anonymous subs (really just making sure they don't crash, since the prototypes +# themselves aren't much use) +{ + is eval 'package Q; my $a = sub(bar) : prototype(baz) {}; 1;', 1, + "Sanity checking that eval of anonymous sub didn't croak"; + # The fact that the name is '?' in the first case + # and __ANON__ in the second is due to toke.c temporarily setting + # the name to '?' before calling the proto check, despite setting + # it to the real name very shortly after. + # In short - if this test breaks, just change the test. + like shift @warnings, 'Illegal character in prototype for \? : bar', + "(anon) bar triggers illegal proto warnings"; + like shift @warnings, "Illegal character in prototype for Q::__ANON__ : baz", + "(anon) baz triggers illegal proto warnings"; + like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__', + "(anon) overridden warning triggered in anonymous sub"; + is @warnings, 0, "No more warnings"; +} + +# Testing lexical subs +{ + use feature "lexical_subs"; + no warnings "experimental::lexical_subs"; + $ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;'; + is $ret, "baz", "my sub foo honors the prototype attribute"; + like shift @warnings, 'Illegal character in prototype for foo : bar', + "(lexical) bar triggers illegal proto warnings"; + like shift @warnings, "Illegal character in prototype for foo : baz", + "(lexical) baz triggers illegal proto warnings"; + like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo', + "(lexical) overridden warning triggered in anonymous sub"; + is @warnings, 0, "No more warnings"; +} + +# Local variables: +# indent-tabs-mode: nil +# End: +# +# ex: set ts=8 sts=4 sw=4 et: |