In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8e79de622f8117bcb196b5a85a9011de655a2d2a?hp=b488d167b095ca65d77037883935ed13df7ee79f>
- Log ----------------------------------------------------------------- commit 8e79de622f8117bcb196b5a85a9011de655a2d2a Merge: b488d16 9973406 Author: Father Chrysostomos <[email protected]> Date: Mon Jan 19 20:34:34 2015 -0800 [Merge] :const commit 997340692b82e720b661394ed6fca1989b1abc2d Author: Father Chrysostomos <[email protected]> Date: Mon Jan 19 20:33:01 2015 -0800 Document :const M ext/attributes/attributes.pm M pod/perlexperiment.pod M pod/perlsub.pod commit 4a873d7a0f3c3698425007a136dda05b0adef997 Author: Father Chrysostomos <[email protected]> Date: Mon Jan 19 19:30:46 2015 -0800 Make :const experimental M lib/B/Deparse.t M pod/perldiag.pod M t/op/anonconst.t M toke.c commit 87ed281958d39d54ae68197a1113e54634ab8e65 Author: Father Chrysostomos <[email protected]> Date: Mon Jan 19 19:21:16 2015 -0800 Add experimental::const_attr warning category M lib/warnings.pm M regen/warnings.pl M warnings.h commit 78f8e7db7bcb78a0be455ec5dda3ce40176168bf Author: Father Chrysostomos <[email protected]> Date: Sun Jan 18 23:01:33 2015 -0800 attributes.xs: Remove dVAR I think it has been redundant ever since it was added in 97aff369. M ext/attributes/attributes.xs commit 3108f4dfc5963ac9d63390f67ac6697a36bf21b4 Author: Father Chrysostomos <[email protected]> Date: Sun Jan 18 22:40:09 2015 -0800 Let attributes.pm know about the const attribute Setting it has no affect except on closure prototypes, so warn if an attempt is made to set it on any other sub. M ext/attributes/attributes.pm M ext/attributes/attributes.xs M pod/perldiag.pod M t/op/attrs.t commit 56c1c96f488940636d0ba81097097eeee1420ce4 Author: Father Chrysostomos <[email protected]> Date: Sun Jan 18 17:40:34 2015 -0800 anonconst.t for testing :const M MANIFEST A t/op/anonconst.t commit b77472f98ff245a83a062d4af8169d2fcbe089e6 Author: Father Chrysostomos <[email protected]> Date: Sun Jan 18 16:37:03 2015 -0800 Add :const anon sub attribute M ext/Opcode/Opcode.pm M lib/B/Deparse.pm M lib/B/Op_private.pm M op.c M opcode.h M opnames.h M pod/perldiag.pod M pp.c M pp_proto.h M regen/opcodes M toke.c commit 956dfca8c907877d52b97e2ad0d2d29d5d1d8442 Author: Father Chrysostomos <[email protected]> Date: Sun Jan 18 16:28:27 2015 -0800 cv.h: Add CVf_ANONCONST flag M cv.h ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + cv.h | 7 ++++- ext/Opcode/Opcode.pm | 2 +- ext/attributes/attributes.pm | 19 +++++++++--- ext/attributes/attributes.xs | 15 +++++++++- lib/B/Deparse.pm | 8 +++-- lib/B/Deparse.t | 12 ++++---- lib/B/Op_private.pm | 1 + lib/warnings.pm | 69 ++++++++++++++++++++++++-------------------- op.c | 11 +++++-- opcode.h | 9 +++++- opnames.h | 3 +- pod/perldiag.pod | 20 +++++++++++++ pod/perlexperiment.pod | 12 ++++++++ pod/perlsub.pod | 15 ++++++++++ pp.c | 11 +++++++ pp_proto.h | 1 + regen/opcodes | 1 + regen/warnings.pl | 2 ++ t/op/anonconst.t | 51 ++++++++++++++++++++++++++++++++ t/op/attrs.t | 24 +++++++++++++++ toke.c | 15 +++++++++- warnings.h | 17 ++++++----- 23 files changed, 266 insertions(+), 60 deletions(-) create mode 100644 t/op/anonconst.t diff --git a/MANIFEST b/MANIFEST index 65ead36..22a0d20 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5227,6 +5227,7 @@ t/mro/vulcan_dfs_utf8.t utf8 mro tests toke.c The tokener t/op/64bitint.t See if 64 bit integers work t/op/alarm.t See if alarm works +t/op/anonconst.t See if :const works t/op/anonsub.t See if anonymous subroutines work t/op/append.t See if . works t/op/args.t See if operations on @_ work diff --git a/cv.h b/cv.h index a3cbdb3..89e471c 100644 --- a/cv.h +++ b/cv.h @@ -134,9 +134,10 @@ See L<perlguts/Autoloading with XSUBs>. #define CVf_HASEVAL 0x4000 /* contains string eval */ #define CVf_NAMED 0x8000 /* Has a name HEK */ #define CVf_LEXICAL 0x10000 /* Omit package from name */ +#define CVf_ANONCONST 0x20000 /* :const - create anonconst op */ /* This symbol for optimised communication between toke.c and op.c: */ -#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE) +#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE|CVf_ANONCONST) #define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) #define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) @@ -219,6 +220,10 @@ See L<perlguts/Autoloading with XSUBs>. #define CvLEXICAL_on(cv) (CvFLAGS(cv) |= CVf_LEXICAL) #define CvLEXICAL_off(cv) (CvFLAGS(cv) &= ~CVf_LEXICAL) +#define CvANONCONST(cv) (CvFLAGS(cv) & CVf_ANONCONST) +#define CvANONCONST_on(cv) (CvFLAGS(cv) |= CVf_ANONCONST) +#define CvANONCONST_off(cv) (CvFLAGS(cv) &= ~CVf_ANONCONST) + /* Flags for newXS_flags */ #define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */ diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 94d3b21..b2a75d3 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -337,7 +337,7 @@ invert_opset function. warn die lineseq nextstate scope enter leave - rv2cv anoncode prototype coreargs + rv2cv anoncode prototype coreargs anonconst entersub leavesub leavesublv return method method_named method_super method_redir method_redir_super diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index dfd3a25..062cd77 100644 --- a/ext/attributes/attributes.pm +++ b/ext/attributes/attributes.pm @@ -23,6 +23,12 @@ $deprecated{CODE} = qr/\A-?(locked)\z/; $deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = qr/\A-?(unique)\z/; +my %msg = ( + lvalue => 'lvalue attribute applied to already-defined subroutine', + -lvalue => 'lvalue attribute removed from already-defined subroutine', + const => 'Useless use of attribute "const"', +); + sub _modify_attrs_and_deprecate { my $svtype = shift; # Now that we've removed handling of locked from the XS code, we need to @@ -34,13 +40,11 @@ sub _modify_attrs_and_deprecate { require warnings; warnings::warnif('deprecated', "Attribute \"$1\" is deprecated"); 0; - } : $svtype eq 'CODE' && /^-?lvalue\z/ ? do { + } : $svtype eq 'CODE' && exists $msg{$_} ? do { require warnings; warnings::warnif( 'misc', - "lvalue attribute " - . (/^-/ ? "removed from" : "applied to") - . " already-defined subroutine" + $msg{$_} ); 0; } : 1 @@ -256,6 +260,13 @@ attribute will be sanity checked at compile time. The "locked" attribute is deprecated, and has no effect in 5.10.0 and later. It was used as part of the now-removed "Perl 5.005 threads". +=item const + +This experimental attribute, introduced in Perl 5.22, only applies to +anonymous subroutines. It causes the subroutine to be called as soon as +the C<sub> expression is evaluated. The return value is captured and +turned into a constant subroutine. + =back The following are the built-in attributes for variables: diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs index 6b36812..b1dd60f 100644 --- a/ext/attributes/attributes.xs +++ b/ext/attributes/attributes.xs @@ -28,7 +28,6 @@ static int modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { - dVAR; SV *attr; int nret; @@ -44,6 +43,20 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) switch (SvTYPE(sv)) { case SVt_PVCV: switch ((int)len) { + case 5: + if (memEQ(name, "const", 5)) { + if (negated) + CvANONCONST_off(sv); + else { + const bool warn = (!CvCLONE(sv) || CvCLONED(sv)) + && !CvANONCONST(sv); + CvANONCONST_on(sv); + if (warn) + break; + } + continue; + } + break; case 6: switch (name[3]) { case 'l': diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index c496c8a..740192d 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -58,7 +58,7 @@ BEGIN { # be to fake up a dummy constant that will never actually be true. foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE - RXf_PMf_CHARSET RXf_PMf_KEEPCOPY + RXf_PMf_CHARSET RXf_PMf_KEEPCOPY CVf_ANONCONST CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV @@ -1213,11 +1213,12 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); if ($cv->FLAGS & SVf_POK) { $proto = "(". $cv->PV . ") "; } - if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) { + if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) { $proto .= ": "; $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; + $proto .= "const " if $cv->CvFLAGS & CVf_ANONCONST; } local($self->{'curcv'}) = $cv; @@ -2587,6 +2588,9 @@ sub pp_refgen { my $kid = $op->first; if ($kid->name eq "null") { my $anoncode = $kid = $kid->first; + if ($anoncode->name eq "anonconst") { + $anoncode = $anoncode->first->first->sibling; + } if ($anoncode->name eq "anoncode" or !null($anoncode = $kid->sibling) and $anoncode->name eq "anoncode") { diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 95a09e6..b91598b 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -1857,12 +1857,12 @@ my sub f {} print f(); >>>> use feature 'lexical_subs'; -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x15\x54\x05"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x55\x50\x15"} my sub f { - BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x15\x04"} + BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x55\x10"} } -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x15\x04"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x55\x10"} print f(); #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" @@ -1873,13 +1873,13 @@ state sub f {} print f(); >>>> use feature 'lexical_subs'; -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x15\x54\x05"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x55\x50\x15"} CORE::state sub f { - BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x15\x04"} + BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x55\x10"} use feature 'state'; } -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x15\x04"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x55\x10"} use feature 'state'; print f(); #### diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index 32f8e20..9a48b96 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -240,6 +240,7 @@ $bits{akeys}{0} = $bf[0]; $bits{alarm}{0} = $bf[0]; $bits{and}{0} = $bf[0]; $bits{andassign}{0} = $bf[0]; +$bits{anonconst}{0} = $bf[0]; @{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); @{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); @{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); diff --git a/lib/warnings.pm b/lib/warnings.pm index 833a899..2020568 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -94,18 +94,19 @@ our %Offsets = ( # Warnings Categories added in Perl 5.021 'everything' => 120, - 'experimental::re_strict'=> 122, - 'experimental::refaliasing'=> 124, - 'experimental::win32_perlio'=> 126, - 'locale' => 128, - 'missing' => 130, - 'redundant' => 132, - 'extra' => 134, - 'void_unusual' => 136, + 'experimental::const_attr'=> 122, + 'experimental::re_strict'=> 124, + 'experimental::refaliasing'=> 126, + 'experimental::win32_perlio'=> 128, + 'locale' => 130, + 'missing' => 132, + 'redundant' => 134, + 'extra' => 136, + 'void_unusual' => 138, ); our %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x15\x00", # [0..59,61..66] + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x00", # [0..59,61..67] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29] 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30] 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] @@ -113,21 +114,22 @@ our %Bits = ( 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] - 'everything' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..68] + 'everything' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..69] 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15\x54\x00\x00", # [51..58,61..63] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15\x54\x01\x00", # [51..58,61..64] 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [56] + 'experimental::const_attr'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [61] 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [52] 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [53] 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [57] - 'experimental::re_strict'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [61] - 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [62] + 'experimental::re_strict'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [62] + 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [63] 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [54] 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [58] 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [55] - 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [63] - 'extra' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01", # [67,68] + 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [64] + 'extra' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05", # [68,69] 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [47] 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [46] @@ -135,10 +137,10 @@ our %Bits = ( 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [5..11,59] 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [64] + 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [65] 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [65] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [66] 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [48] 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [49] @@ -155,7 +157,7 @@ our %Bits = ( 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] - 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [66] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [67] 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [38] @@ -173,11 +175,11 @@ our %Bits = ( 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [43] 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00\x00\x00", # [44,48..50] 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [45] - 'void_unusual' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [68] + 'void_unusual' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [69] ); our %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xa8\x2a\x00", # [0..59,61..66] + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xa8\xaa\x00", # [0..59,61..67] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29] 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30] 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] @@ -185,21 +187,22 @@ our %DeadBits = ( 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] - 'everything' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..68] + 'everything' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..69] 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a\xa8\x00\x00", # [51..58,61..63] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a\xa8\x02\x00", # [51..58,61..64] 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [56] + 'experimental::const_attr'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [61] 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [52] 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [53] 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [57] - 'experimental::re_strict'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [61] - 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [62] + 'experimental::re_strict'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [62] + 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [63] 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [54] 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [58] 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [55] - 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [63] - 'extra' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02", # [67,68] + 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [64] + 'extra' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a", # [68,69] 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [47] 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [46] @@ -207,10 +210,10 @@ our %DeadBits = ( 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [5..11,59] 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [64] + 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [65] 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [65] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [66] 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [48] 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [49] @@ -227,7 +230,7 @@ our %DeadBits = ( 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] - 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [66] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [67] 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [38] @@ -245,12 +248,12 @@ our %DeadBits = ( 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [43] 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00\x00\x00", # [44,48..50] 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [45] - 'void_unusual' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [68] + 'void_unusual' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [69] ); $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; -$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x54\x01\x00", # [2,56,52,53,57,61,62,54,58,55,63,4,64,22,23,25] -$LAST_BIT = 138 ; +$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x54\x05\x00", # [2,56,61,52,53,57,62,63,54,58,55,64,4,65,22,23,25] +$LAST_BIT = 140 ; $BYTES = 18 ; $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; @@ -814,6 +817,8 @@ The current hierarchy is: | | | | | +- experimental::autoderef | | | + | | +- experimental::const_attr + | | | | | +- experimental::lexical_subs | | | | | +- experimental::lexical_topic diff --git a/op.c b/op.c index c1d4172..6ed08a3 100644 --- a/op.c +++ b/op.c @@ -9274,9 +9274,16 @@ Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) OP * Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { - return newUNOP(OP_REFGEN, 0, + SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)); + OP * anoncode = newSVOP(OP_ANONCODE, 0, - MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); + cv); + if (CvANONCONST(cv)) + anoncode = newUNOP(OP_ANONCONST, 0, + op_convert_list(OP_ENTERSUB, + OPf_STACKED|OPf_WANT_SCALAR, + anoncode)); + return newUNOP(OP_REFGEN, 0, anoncode); } OP * diff --git a/opcode.h b/opcode.h index 33e7e3d..5d910fd 100644 --- a/opcode.h +++ b/opcode.h @@ -535,6 +535,7 @@ EXTCONST char* const PL_op_name[] = { "lvref", "lvrefslice", "lvavref", + "anonconst", "freed", }; #endif @@ -930,6 +931,7 @@ EXTCONST char* const PL_op_desc[] = { "lvalue ref assignment", "lvalue ref assignment", "lvalue array reference", + "anonymous constant", "freed op", }; #endif @@ -1339,6 +1341,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_lvref, Perl_pp_lvrefslice, Perl_pp_lvavref, + Perl_pp_anonconst, } #endif #ifdef PERL_PPADDR_INITED @@ -1744,6 +1747,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* lvref */ Perl_ck_null, /* lvrefslice */ Perl_ck_null, /* lvavref */ + Perl_ck_null, /* anonconst */ } #endif #ifdef PERL_CHECK_INITED @@ -2143,6 +2147,7 @@ EXTCONST U32 PL_opargs[] = { 0x00000b40, /* lvref */ 0x00000440, /* lvrefslice */ 0x00000b40, /* lvavref */ + 0x00000144, /* anonconst */ }; #endif @@ -2772,6 +2777,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 200, /* lvref */ 206, /* lvrefslice */ 207, /* lvavref */ + 0, /* anonconst */ }; @@ -2790,7 +2796,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { */ EXTCONST U16 PL_op_private_bitdefs[] = { - 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i ... [579 chars truncated] + 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i ... [590 chars truncated] 0x29dc, 0x3bd9, /* pushmark */ 0x00bd, /* wantarray, runcv */ 0x03b8, 0x1570, 0x3c8c, 0x3748, 0x2da5, /* const */ @@ -3250,6 +3256,7 @@ EXTCONST U8 PL_op_private_valid[] = { /* LVREF */ (OPpARG1_MASK|OPpLVREF_ELEM|OPpLVREF_ITER|OPpLVREF_TYPE|OPpPAD_STATE|OPpLVAL_INTRO), /* LVREFSLICE */ (OPpLVAL_INTRO), /* LVAVREF */ (OPpARG1_MASK|OPpPAD_STATE|OPpLVAL_INTRO), + /* ANONCONST */ (OPpARG1_MASK), }; diff --git a/opnames.h b/opnames.h index 1d259a1..013350a 100644 --- a/opnames.h +++ b/opnames.h @@ -401,10 +401,11 @@ typedef enum opcode { OP_LVREF = 384, OP_LVREFSLICE = 385, OP_LVAVREF = 386, + OP_ANONCONST = 387, OP_max } opcode; -#define MAXO 387 +#define MAXO 388 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 650839c..54ac481 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1699,6 +1699,19 @@ to define an overloaded constant, or when trying to find the character name specified in the C<\N{...}> escape. Perhaps you forgot to load the corresponding L<overload> pragma?. +=item :const is experimental + +(S experimental::const_attr) The "const" attribute is experimental. +If you want to use the feature, disable the warning with C<no warnings +'experimental::const_attr'>, but know that in doing so you are taking +the risk that your code may break in a future Perl version. + +=item :const is not permitted on named subroutines + +(F) The "const" attribute causes an anonymous subroutine to be run and +its value captured at the time that it is cloned. Names subroutines are +not cloned like this, so the attribute does not make sense on them. + =item Copy method did not return a reference (F) The method which overloads "=" is buggy. See @@ -6434,6 +6447,13 @@ must be written as The <-- HERE shows whereabouts in the regular expression the problem was discovered. See L<perlre>. +=item Useless use of attribute "const" + +(W misc) The "const" attribute has no effect except +on anonymous closure prototypes. You applied it to +a subroutine via L<attributes.pm|attributes>. This is only useful +inside an attribute handler for an anonymous subroutine. + =item Useless use of /d modifier in transliteration operator (W misc) You have used the /d modifier where the searchlist has the diff --git a/pod/perlexperiment.pod b/pod/perlexperiment.pod index ee48e23..be0e0de 100644 --- a/pod/perlexperiment.pod +++ b/pod/perlexperiment.pod @@ -123,6 +123,18 @@ L<[perl #122947]|https://rt.perl.org/rt3/Ticket/Display.html?id=122947>. See also: L<perlref/Assigning to References> +=item The "const" attribute + +Introduced in Perl 5.22.0 + +Using this feature triggers warnings in the category +C<experimental::const_attr>. + +The ticket for this feature is +L<[perl #xxxxx]|https://rt.perl.org/rt3/Ticket/Display.html?id=xxxxx>. + +See also: L<perlsub/Constant Functions> + =item The <:win32> IO pseudolayer The ticket for this feature is diff --git a/pod/perlsub.pod b/pod/perlsub.pod index a6d000d..ea27583 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -1701,6 +1701,21 @@ declared. *ALSO_INLINED = sub () { $x }; } +Perl 5.22 also introduces the experimental "const" attribute as an +alternative. (Disable the "experimental::const_attr" warnings if you want +to use it.) When applied to an anonymous subroutine, it forces the sub to +be called when the C<sub> expression is evaluated. The return value is +captured and turned into a constant subroutine: + + my $x = 54321; + *INLINED = sub : const { $x }; + $x++; + +The return value of C<INLINED> in this example will always be 54321, +regardless of later modifications to $x. You can also put any arbitrary +code inside the sub, at it will be executed immediately and its return +value captured the same way. + If you really want a subroutine with a C<()> prototype that returns a lexical variable you can easily force it to not be inlined by adding an explicit C<return>: diff --git a/pp.c b/pp.c index 8c66286..c4c4819 100644 --- a/pp.c +++ b/pp.c @@ -6376,6 +6376,17 @@ PP(pp_lvavref) } } +PP(pp_anonconst) +{ + dSP; + dTOPss; + SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV + ? CopSTASH(PL_curcop) + : NULL, + NULL, SvREFCNT_inc_simple_NN(sv)))); + RETURN; +} + /* * Local variables: * c-indentation-style: bsd diff --git a/pp_proto.h b/pp_proto.h index 074f4ab..bbf6cf5 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -16,6 +16,7 @@ PERL_CALLCONV OP *Perl_pp_akeys(pTHX); PERL_CALLCONV OP *Perl_pp_alarm(pTHX); PERL_CALLCONV OP *Perl_pp_and(pTHX); PERL_CALLCONV OP *Perl_pp_anoncode(pTHX); +PERL_CALLCONV OP *Perl_pp_anonconst(pTHX); PERL_CALLCONV OP *Perl_pp_anonhash(pTHX); PERL_CALLCONV OP *Perl_pp_anonlist(pTHX); PERL_CALLCONV OP *Perl_pp_aslice(pTHX); diff --git a/regen/opcodes b/regen/opcodes index f585cd2..3061d33 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -565,3 +565,4 @@ refassign lvalue ref assignment ck_refassign ds2 lvref lvalue ref assignment ck_null d% lvrefslice lvalue ref assignment ck_null d@ lvavref lvalue array reference ck_null d% +anonconst anonymous constant ck_null ds1 diff --git a/regen/warnings.pl b/regen/warnings.pl index 2c23c46..e53059d 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -106,6 +106,8 @@ my $tree = { [ 5.021, DEFAULT_ON ], 'experimental::re_strict' => [ 5.021, DEFAULT_ON ], + 'experimental::const_attr' => + [ 5.021, DEFAULT_ON ], }], 'missing' => [ 5.021, DEFAULT_OFF], diff --git a/t/op/anonconst.t b/t/op/anonconst.t new file mode 100644 index 0000000..b281cc1 --- /dev/null +++ b/t/op/anonconst.t @@ -0,0 +1,51 @@ +#!./perl + +BEGIN { + chdir 't'; + require './test.pl'; + @INC = "../lib"; +} + +plan 8; + +{ + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval '+sub : const {}'; + like $w, qr/^:const is experimental at /, 'experimental warning'; +} + +no warnings 'experimental::const_attr'; + +push @subs, sub :const{$_} for 1..10; +is join(" ", map &$_, @subs), "1 2 3 4 5 6 7 8 9 10", + ':const capturing global $_'; + +my $x = 3; +my $sub = sub : const { $x }; +$x++; +is &$sub, 3, ':const capturing lexical'; + +$x = 3; +$sub = sub : const { $x+5 }; +$x++; +is &$sub, 8, ':const capturing expression'; + +is &{sub () : const { 42 }}, 42, ':const with truly constant sub'; + +*foo = $sub; +{ + use warnings 'redefine'; + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + *foo = sub (){}; + like $w, qr/^Constant subroutine main::foo redefined at /, + ':const subs are constant'; +} + +eval 'sub bar : const'; +like $@, qr/^:const is not permitted on named subroutines at /, + ':const on named stub'; +eval 'sub baz : const { }'; +like $@, qr/^:const is not permitted on named subroutines at /, + ':const on named sub'; diff --git a/t/op/attrs.t b/t/op/attrs.t index 2761d47..f8515fb 100644 --- a/t/op/attrs.t +++ b/t/op/attrs.t @@ -389,4 +389,28 @@ package ProtoTest { } is $ProtoTest::Proto, '$', 'prototypes are visible in attr handlers'; +{ + my $w; + local $SIG{__WARN__} = sub { $w = shift }; + attributes ->import(__PACKAGE__, \&foo, "const"); + like $w, qr/^Useless use of attribute "const" at /, + 'Warning for useless const via attributes.pm'; + $w = ''; + attributes ->import(__PACKAGE__, \&foo, "const"); + is $w, '', 'no warning for const if already applied'; + attributes ->import(__PACKAGE__, \&foo, "-const"); + is $w, '', 'no warning for -const with attr already applied'; + attributes ->import(__PACKAGE__, \&bar, "-const"); + is $w, '', 'no warning for -const with attr not already applied'; + package ConstTest; + sub MODIFY_CODE_ATTRIBUTES { + attributes->import(shift, shift, lc shift) if $_[2]; () + } + $_ = 32487; + my $sub = sub : Const { $_ }; + undef $_; + ::is &$sub, 32487, + 'applying const attr via attributes.pm'; +} + done_testing(); diff --git a/toke.c b/toke.c index dfb5b20..55d3af9 100644 --- a/toke.c +++ b/toke.c @@ -5366,6 +5366,19 @@ Perl_yylex(pTHX) sv_free(sv); CvMETHOD_on(PL_compcv); } + else if (!PL_in_my && len == 5 + && strnEQ(SvPVX(sv), "const", len)) + { + sv_free(sv); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__CONST_ATTR), + ":const is experimental" + ); + CvANONCONST_on(PL_compcv); + if (!CvANON(PL_compcv)) + yyerror(":const is not permitted on named " + "subroutines"); + } /* After we've set the flags, it could be argued that we don't need to do the attributes.pm-based setting process, and shouldn't bother appending recognized @@ -10591,7 +10604,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) CvFLAGS(PL_compcv) |= flags; PL_subline = CopLINE(PL_curcop); - CvPADLIST_set(PL_compcv, pad_new(padnew_SAVE|padnew_SAVESUB)); + CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; if (outsidecv && CvPADLIST(outsidecv)) diff --git a/warnings.h b/warnings.h index a079c38..6a80096 100644 --- a/warnings.h +++ b/warnings.h @@ -105,14 +105,15 @@ /* Warnings Categories added in Perl 5.021 */ #define WARN_EVERYTHING 60 -#define WARN_EXPERIMENTAL__RE_STRICT 61 -#define WARN_EXPERIMENTAL__REFALIASING 62 -#define WARN_EXPERIMENTAL__WIN32_PERLIO 63 -#define WARN_LOCALE 64 -#define WARN_MISSING 65 -#define WARN_REDUNDANT 66 -#define WARN_EXTRA 67 -#define WARN_VOID_UNUSUAL 68 +#define WARN_EXPERIMENTAL__CONST_ATTR 61 +#define WARN_EXPERIMENTAL__RE_STRICT 62 +#define WARN_EXPERIMENTAL__REFALIASING 63 +#define WARN_EXPERIMENTAL__WIN32_PERLIO 64 +#define WARN_LOCALE 65 +#define WARN_MISSING 66 +#define WARN_REDUNDANT 67 +#define WARN_EXTRA 68 +#define WARN_VOID_UNUSUAL 69 #define WARNsize 18 #define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125" -- Perl5 Master Repository
