diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index 6831269f1cbe..09c2c488db57 100644 --- a/ext/attributes/attributes.pm +++ b/ext/attributes/attributes.pm @@ -1,12 +1,14 @@ -package attributes; +package attributes 0.37; -our $VERSION = 0.36; +use v5.40; -@EXPORT_OK = qw(get reftype); -@EXPORT = (); -%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]); +our @EXPORT_OK = qw(get reftype); +our @EXPORT = (); +our %EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]); -use strict; +# Older versions of this module provided a `reftype` in attributes.xs, and +# there may exist code out there that relies on being able to find it. +*reftype = \&builtin::reftype; sub croak { require Carp; @@ -28,27 +30,24 @@ my %msg = ( const => 'Useless use of attribute "const"', ); -sub _modify_attrs_and_deprecate { - my $svtype = shift; +my sub modify_attrs_and_deprecate ($svtype, @args) { # After we've removed a deprecated attribute from the XS code, we need to # remove it here, else it ends up in @badattrs. (If we do the deprecation in # XS, we can't control the warning based on *our* caller's lexical settings, # and the warned line is in this package) grep { $deprecated{$svtype} && /$deprecated{$svtype}/ ? do { - require warnings; warnings::warnif('deprecated', "Attribute \"$1\" is deprecated, " . "and will disappear in Perl 5.28"); 0; } : $svtype eq 'CODE' && exists $msg{$_} ? do { - require warnings; warnings::warnif( 'misc', $msg{$_} ); 0; } : 1 - } _modify_attrs(@_); + } _modify_attrs(@args); } sub import { @@ -64,7 +63,7 @@ sub import { if defined $home_stash && $home_stash ne ''; my @badattrs; if ($pkgmeth) { - my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs); + my @pkgattrs = modify_attrs_and_deprecate($svtype, $svref, @attrs); @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs); if (!@badattrs && @pkgattrs) { require warnings; @@ -82,7 +81,7 @@ sub import { } } else { - @badattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs); + @badattrs = modify_attrs_and_deprecate($svtype, $svref, @attrs); } if (@badattrs) { croak "Invalid $svtype attribute" . @@ -92,13 +91,11 @@ sub import { } } -sub get ($) { - @_ == 1 && ref $_[0] or +sub get :prototype($) ($svref) { + ref $svref or croak 'Usage: '.__PACKAGE__.'::get $ref'; - my $svref = shift; my $svtype = uc reftype($svref); - my $stash = _guess_stash($svref); - $stash = caller unless defined $stash; + my $stash = _guess_stash($svref) // scalar caller; my $pkgmeth; $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES") if defined $stash && $stash ne ''; @@ -113,7 +110,6 @@ sub require_version { goto &UNIVERSAL::VERSION } require XSLoader; XSLoader::load(); -1; __END__ #The POD goes here @@ -295,9 +291,11 @@ Otherwise, only L will be returned. =item reftype -This routine expects a single parameter--a reference to a subroutine or -variable. It returns the built-in type of the referenced variable, -ignoring any package into which it might have been blessed. +This is an alias to L. It is maintained +here for backward compatibility for any code that expected to be able to call +it from this module. Newly-written code should use the function from the +L module directly. + This can be useful for determining the I value which forms part of the method names described in L<"Package-specific Attribute Handling"> below. diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs index 018a6ff86547..bf5753e69c6d 100644 --- a/ext/attributes/attributes.xs +++ b/ext/attributes/attributes.xs @@ -98,8 +98,32 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) subname = newSVhek_mortal(hek); else subname=(SV *)CvGV((const CV *)sv); - if (ckWARN(WARN_ILLEGALPROTO)) - Perl_validate_proto(aTHX_ subname, proto, TRUE, 0); + { + /* Need to check if the caller has WARN_ILLEGALPROTO + * set. That might be PL_curcop or it might be higher + * up, we'll have to check + */ + + COP *cop = PL_curcop; + int caller_level = 0; + const char *stashname; + while (cop && (stashname = HvNAME(CopSTASH(cop))) && + strEQ(stashname, "attributes")) { + // skip caller frames from attributes.pm itself + caller_level++; + cop = caller_cx(caller_level, NULL)->blk_oldcop; + } + + if (cop && cop_has_warning(cop, WARN_ILLEGALPROTO)) { + ENTER; + SAVESPTR(PL_curcop); + PL_curcop = cop; + + Perl_validate_proto(aTHX_ subname, proto, TRUE, 0); + + LEAVE; + } + } Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv, (const GV *)subname, name+10, @@ -228,29 +252,6 @@ usage: SvSETMAGIC(TARG); XSRETURN(1); - -void -reftype(...) - PROTOTYPE: $ - PREINIT: - SV *rv, *sv; - dXSTARG; - PPCODE: - if (items != 1) { -usage: - croak_xs_usage(cv, "$reference"); - } - - rv = ST(0); - ST(0) = TARG; - SvGETMAGIC(rv); - if (!(SvOK(rv) && SvROK(rv))) - goto usage; - sv = SvRV(rv); - sv_setpv(TARG, sv_reftype(sv, 0)); - SvSETMAGIC(TARG); - - XSRETURN(1); /* * ex: set ts=8 sts=4 sw=4 et: */ diff --git a/t/op/attrproto.t b/t/op/attrproto.t index 57e1084df9be..26d888065341 100644 --- a/t/op/attrproto.t +++ b/t/op/attrproto.t @@ -11,13 +11,14 @@ BEGIN { } use warnings; -plan tests => 48; +plan tests => 52; my @warnings; my ($attrs, $ret) = ("", ""); sub Q::MODIFY_CODE_ATTRIBUTES { my ($name, $ref, @attrs) = @_; $attrs = "@attrs";return;} $SIG{__WARN__} = sub { push @warnings, shift;}; +@warnings = (); $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(..)"; @@ -27,20 +28,24 @@ like shift @warnings, qr/Illegal character in prototype for Q::A : bad/, "Second warning is bad prototype - bad"; like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A/, "Third warning is Prototype overridden"; -is @warnings, 0, "No more warnings"; +is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; # The override warning should not be hidden by no warnings (similar to prototype changed warnings) { no warnings 'illegalproto'; + @warnings = (); $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, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B/, "First warning is Prototype overridden"; - is @warnings, 0, "No more warnings"; + is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; } # Redeclaring a sub with a prototype attribute ignores it +@warnings = (); $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(..)"; @@ -52,9 +57,11 @@ like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototy "Shifting off Prototype overridden warning"; like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, "Attempting to redeclare triggers prototype mismatch warning against first prototype"; -is @warnings, 0, "No more warnings"; +is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; # Confirm redifining with a prototype attribute takes it +@warnings = (); $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(..)"; @@ -69,29 +76,48 @@ like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, "Attempting to redeclare triggers prototype mismatch warning"; like shift @warnings, qr/Subroutine B redefined/, "Only other warning is subroutine redefinition"; -is @warnings, 0, "No more warnings"; +is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; # Multiple prototype declarations only takes the last one +@warnings = (); $ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;'; is $ret, "\$\$\$", "Last prototype declared wins"; like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/, "Multiple prototype declarations warns"; -is @warnings, 0, "No more warnings"; +is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; # Use attributes -eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";'; +@warnings = (); +eval 'package Q; no warnings "illegalproto"; use attributes __PACKAGE__, \&B, "prototype(new)";'; $ret = prototype \&Q::B; is $ret, "new", "use attributes also sets the prototype"; like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/, "Prototype mismatch warning triggered"; -is @warnings, 0, "No more warnings"; +is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; +@warnings = (); eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";'; $ret = prototype \&Q::B; is $ret, "new", "A malformed prototype doesn't reset it"; like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; is @warnings, 0, "Malformed prototype isn't just a warning"; +# Respects `use warnings 'illegalproto'` of the right caller +@warnings = (); +eval 'package Q; use warnings; sub C {} use attributes __PACKAGE__, \&C, "prototype(bad)";'; +$ret = prototype \&Q::C; +is $ret, "bad", "illegal prototype is still set via use attributes"; +like shift @warnings, qr/^Illegal character in prototype for \*Q::C : bad at /, + "Illegal prototype warning triggered"; +like shift @warnings, qr/^Prototype mismatch: sub Q::C: none vs \(bad\) at /, + "Prototype mismatch warning triggered"; +is @warnings, 0, "No more warnings" or + diag "More warning: $warnings[0]"; + +@warnings = (); eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";'; $ret = prototype \&Q::B; is $ret, "new", "A malformed prototype doesn't reset it"; @@ -114,7 +140,8 @@ is @warnings, 0, "Malformed prototype isn't just a warning"; "(anon) baz triggers illegal proto warnings"; like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__/, "(anon) overridden warning triggered in anonymous sub"; - is @warnings, 0, "No more warnings"; + is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; } # Testing lexical subs @@ -129,7 +156,8 @@ is @warnings, 0, "Malformed prototype isn't just a warning"; "(lexical) baz triggers illegal proto warnings"; like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in lexsub1/, "(lexical) overridden warning triggered in anonymous sub"; - is @warnings, 0, "No more warnings"; + is @warnings, 0, "No more warnings" + or diag "Next warning: $warnings[0]"; } # ex: set ts=8 sts=4 sw=4 et: