This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Adding a prototype attribute.
authorPeter Martini <PeterCMartini@GMail.com>
Sun, 13 Oct 2013 20:00:00 +0000 (16:00 -0400)
committerJames E Keenan <jkeenan@cpan.org>
Wed, 16 Oct 2013 11:17:44 +0000 (13:17 +0200)
This attribute adds an additional way of declaring a prototype for a
sub, making sub foo($$) and sub foo : prototype($$) equivalent.  The
intent is to keep the functionality of prototypes while allowing other
modules to use the syntactic space it currently occupies for other
purposes.

The attribute is supported in attributes.xs to allow
attributes::->import to work, but if its defined inline via something
like sub foo : prototype($$) {}, it will not call out to the
attributes module.

For: RT #119251

MANIFEST
embed.fnc
embed.h
ext/attributes/attributes.pm
ext/attributes/attributes.xs
op.c
pod/perldelta.pod
pod/perldiag.pod
pod/perlsub.pod
proto.h
t/op/attrproto.t [new file with mode: 0644]

index 741b08b..af911bc 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
index 5320a34..8ffecaf 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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
diff --git a/embed.h b/embed.h
index 9dfd3ea..00058f1 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
 #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)
 #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)
index 5a656a6..7c3c0b0 100644 (file)
@@ -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.
index d39b77a..dbb644d 100644 (file)
@@ -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:
diff --git a/op.c b/op.c
index 29c9467..c4db56f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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);
index 3dcf78f..381f145 100644 (file)
@@ -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
index da4dfbd..6a42e08 100644 (file)
@@ -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
index 2b4b35b..2a9e0a8 100644 (file)
@@ -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 (+@)
 
diff --git a/proto.h b/proto.h
index e966e54..54c6b4f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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 (file)
index 0000000..13ce107
--- /dev/null
@@ -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: