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
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
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
#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)
package attributes;
-our $VERSION = 0.21;
+our $VERSION = 0.22;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
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.
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:
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)
{
[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);
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;
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);
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
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
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>
(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
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 (+@)
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 \
--- /dev/null
+#!./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:
projects / platform / upstream / perl.git / commitdiff