diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.fnc | 4 | ||||
| -rw-r--r-- | gv.c | 62 | ||||
| -rw-r--r-- | lib/CORE.pod | 22 | ||||
| -rw-r--r-- | op.c | 89 | ||||
| -rw-r--r-- | pod/perldiag.pod | 10 | ||||
| -rw-r--r-- | pod/perlsub.pod | 6 | ||||
| -rw-r--r-- | proto.h | 8 | ||||
| -rw-r--r-- | t/op/coreinline.t | 91 |
9 files changed, 284 insertions, 9 deletions
@@ -4917,6 +4917,7 @@ t/op/concat2.t Tests too complex for concat.t t/op/concat.t See if string concatenation works t/op/cond.t See if conditional expressions work t/op/context.t See if context propagation works +t/op/coreinline.t Test inlining of \&CORE::subs t/op/cproto.t Check builtin prototypes t/op/crypt.t See if crypt works t/op/dbm.t See if dbmopen/dbmclose work @@ -880,6 +880,8 @@ Apd |CV* |rv2cv_op_cv |NN OP *cvop|U32 flags Apd |OP* |ck_entersub_args_list|NN OP *entersubop Apd |OP* |ck_entersub_args_proto|NN OP *entersubop|NN GV *namegv|NN SV *protosv Apd |OP* |ck_entersub_args_proto_or_list|NN OP *entersubop|NN GV *namegv|NN SV *protosv +po |OP* |ck_entersub_args_core|NN OP *entersubop|NN GV *namegv \ + |NN SV *protosv Apd |void |cv_get_call_checker|NN CV *cv|NN Perl_call_checker *ckfun_p|NN SV **ckobj_p Apd |void |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems @@ -1645,7 +1647,7 @@ s |void |bad_type |I32 n|NN const char *t|NN const char *name|NN const OP *kid s |void |no_bareword_allowed|NN OP *o sR |OP* |no_fh_allowed|NN OP *o sR |OP* |too_few_arguments|NN OP *o|NN const char* name -sR |OP* |too_many_arguments|NN OP *o|NN const char* name +s |OP* |too_many_arguments|NN OP *o|NN const char* name s |bool |looks_like_bool|NN const OP* o s |OP* |newGIVWHENOP |NULLOK OP* cond|NN OP *block \ |I32 enter_opcode|I32 leave_opcode \ @@ -36,6 +36,7 @@ Perl stores its global variables. #define PERL_IN_GV_C #include "perl.h" #include "overload.c" +#include "keywords.h" static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; @@ -1033,6 +1034,8 @@ S_gv_magicalize_overload(pTHX_ GV *gv) hv_magic(hv, NULL, PERL_MAGIC_overload); } +static void core_xsub(pTHX_ CV* cv); + GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) @@ -1297,7 +1300,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* set up magic where warranted */ if (stash != PL_defstash) { /* not the main stash */ /* We only have to check for four names here: EXPORT, ISA, OVERLOAD - and VERSION. All the others apply only to the main stash. */ + and VERSION. All the others apply only to the main stash or to + CORE (which is checked right after this). */ if (len > 2) { const char * const name2 = name + 1; switch (*name) { @@ -1317,7 +1321,53 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "ERSION")) GvMULTI_on(gv); break; + default: + goto try_core; + } + return gv; + } + try_core: + if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { + /* Avoid null warning: */ + const char * const stashname = HvNAME(stash); assert(stashname); + if (strnEQ(stashname, "CORE", 4)) { + const int code = keyword(name, len, 1); + static const char file[] = __FILE__; + CV *cv; + int opnum = 0; + SV *opnumsv; + if (code >= 0) return gv; /* not overridable */ + /* no support for \&CORE::infix; + no support for &CORE::not or &CORE::getprotobynumber + either, yet, as we cannot get the precedence right; + no support for funcs that take labels, as their parsing is + weird */ + switch (-code) { + case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump: + case KEY_eq: case KEY_ge: + case KEY_getprotobynumber: case KEY_gt: case KEY_le: + case KEY_lt: case KEY_ne: case KEY_not: + case KEY_or: case KEY_x: case KEY_xor: + return gv; } + /* Avoid calling newXS, as it calls us, and things start to + get hairy. */ + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GvCV_set(gv,cv); + GvCVGEN(gv) = 0; + mro_method_changed_in(GvSTASH(gv)); + CvGV_set(cv, gv); + (void)gv_fetchfile(file); + CvFILE(cv) = (char *)file; + CvISXSUB_on(cv); + CvXSUB(cv) = core_xsub; + (void)core_prototype((SV *)cv, name, len, &opnum, 0); + opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; + cv_set_call_checker( + cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv + ); + SvREFCNT_dec(opnumsv); + } } } else if (len > 1) { @@ -2780,6 +2830,16 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) } } +#include "XSUB.h" + +static void +core_xsub(pTHX_ CV* cv) +{ + Perl_croak(aTHX_ + "&CORE::%s cannot be called directly", GvNAME(CvGV(cv)) + ); +} + /* * Local variables: * c-indentation-style: bsd diff --git a/lib/CORE.pod b/lib/CORE.pod index b96c1de2d6..d2175eb56c 100644 --- a/lib/CORE.pod +++ b/lib/CORE.pod @@ -1,6 +1,6 @@ =head1 NAME -CORE - Pseudo-namespace for Perl's core routines +CORE - Namespace for Perl's core routines =head1 SYNOPSIS @@ -12,17 +12,31 @@ CORE - Pseudo-namespace for Perl's core routines print CORE::hex("0x50"),"\n"; # prints 80 CORE::say "yes"; # prints yes + BEGIN { *shove = \&CORE::push; } + shove @array, 1,2,3; # pushes on to @array + =head1 DESCRIPTION The C<CORE> namespace gives access to the original built-in functions of -Perl. It also provides access to keywords normally available -only through the L<feature> pragma. There is no C<CORE> -package, and therefore you do not need to use or +Perl. The C<CORE> package is built into +Perl, and therefore you do not need to use or require an hypothetical "CORE" module prior to accessing routines in this namespace. A list of the built-in functions in Perl can be found in L<perlfunc>. +For all Perl keywords, a C<CORE::> prefix will force the built-in function +to be used, even if it has been overridden or would normally require the +L<feature> pragma. Despite appearances, this has nothing to do with the +CORE package, but is part of Perl's syntax. + +For many Perl functions, the CORE package contains real subroutines. This +feature is new in Perl 5.16. You can take references to these and make +aliases. However, they can only be called as barewords; i.e., you cannot +use ampersand syntax (C<&foo>) or call them through references. See the +C<shove> example above. This works for all overridable keywords, except +for C<dump>, C<getprotobynumber>, C<not> and the infix operators. + =head1 OVERRIDING CORE FUNCTIONS To override a Perl built-in routine with your own version, you need to @@ -9221,6 +9221,95 @@ Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, return ck_entersub_args_list(entersubop); } +OP * +Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) +{ + int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv); + OP *aop = cUNOPx(entersubop)->op_first; + + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; + + if (!opnum) { + OP *prev, *cvop; + if (!aop->op_sibling) + aop = cUNOPx(aop)->op_first; + prev = aop; + aop = aop->op_sibling; + for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) { + aop = aop->op_sibling; + continue; + } + if (aop != cvop) + (void)too_many_arguments(entersubop, GvNAME(namegv)); + + op_free(entersubop); + switch(GvNAME(namegv)[2]) { + case 'F': return newSVOP(OP_CONST, 0, + newSVpv(CopFILE(PL_curcop),0)); + case 'L': return newSVOP( + OP_CONST, 0, + Perl_newSVpvf(aTHX_ + "%"IVdf, (IV)CopLINE(PL_curcop) + ) + ); + case 'P': return newSVOP(OP_CONST, 0, + (PL_curstash + ? newSVhek(HvNAME_HEK(PL_curstash)) + : &PL_sv_undef + ) + ); + } + assert(0); + } + else { + OP *prev, *cvop; + U32 paren; +#ifdef PERL_MAD + bool seenarg = FALSE; +#endif + if (!aop->op_sibling) + aop = cUNOPx(aop)->op_first; + + prev = aop; + aop = aop->op_sibling; + prev->op_sibling = NULL; + for (cvop = aop; + cvop->op_sibling; + prev=cvop, cvop = cvop->op_sibling) +#ifdef PERL_MAD + if (PL_madskills && cvop->op_sibling + && cvop->op_type != OP_STUB) seenarg = TRUE +#endif + ; + prev->op_sibling = NULL; + paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); + op_free(cvop); + if (aop == cvop) aop = NULL; + op_free(entersubop); + + switch (PL_opargs[opnum] & OA_CLASS_MASK) { + case OA_UNOP: + case OA_BASEOP_OR_UNOP: + case OA_FILESTATOP: + return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren); + case OA_BASEOP: + if (aop) { +#ifdef PERL_MAD + if (!PL_madskills || seenarg) +#endif + (void)too_many_arguments(aop, GvNAME(namegv)); + op_free(aop); + } + return newOP(opnum,0); + default: + return convert(opnum,0,aop); + } + } + assert(0); + return entersubop; +} + /* =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d35e364986..4aa76e2e5a 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1475,6 +1475,16 @@ workarounds. (F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>. +=item &CORE::%s cannot be called directly + +(F) You tried to call a subroutine in the C<CORE::> namespace +with C<&foo> syntax or through a reference. The subroutines +in this package cannot yet be called that way, but must be +called as barewords. Something like this will work: + + BEGIN { *shove = \&CORE::push; } + shove @array, 1,2,3; # pushes on to @array + =item CORE::%s is not a keyword (F) The CORE:: namespace is reserved for Perl keywords. diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 4cc0b9c5e7..d344c4745c 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -1309,8 +1309,10 @@ built-in name with the special package qualifier C<CORE::>. For example, saying C<CORE::open()> always refers to the built-in C<open()>, even if the current package has imported some other subroutine called C<&open()> from elsewhere. Even though it looks like a regular -function call, it isn't: you can't take a reference to it, such as -the incorrect C<\&CORE::open> might appear to produce. +function call, it isn't: the CORE:: prefix in that case is part of Perl's +syntax, and works for any keyword, regardless of what is in the CORE +package. Taking a reference to it, that is, C<\&CORE::open>, only works +for some keywords. See L<CORE>. Library modules should not in general export built-in names like C<open> or C<chdir> as part of their default C<@EXPORT> list, because these may @@ -314,6 +314,13 @@ PERL_CALLCONV OP * Perl_ck_each(pTHX_ OP *o) #define PERL_ARGS_ASSERT_CK_EACH \ assert(o) +PERL_CALLCONV OP* Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE \ + assert(entersubop); assert(namegv); assert(protosv) + PERL_CALLCONV OP* Perl_ck_entersub_args_list(pTHX_ OP *entersubop) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST \ @@ -5613,7 +5620,6 @@ STATIC OP* S_too_few_arguments(pTHX_ OP *o, const char* name) assert(o); assert(name) STATIC OP* S_too_many_arguments(pTHX_ OP *o, const char* name) - __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS \ diff --git a/t/op/coreinline.t b/t/op/coreinline.t new file mode 100644 index 0000000000..b4f8796b23 --- /dev/null +++ b/t/op/coreinline.t @@ -0,0 +1,91 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = qw(. ../lib); + require "test.pl"; + skip_all_without_dynamic_extension('B'); + $^P |= 0x100; +} + +use B::Deparse; +my $bd = new B::Deparse; + +my %unsupported = map +($_=>1), qw (CORE and cmp dump eq ge gt le + getprotobynumber lt ne not or x xor); +my %args_for = ( + dbmopen => '%1,$2,$3', + dbmclose => '%1', +); + +use File::Spec::Functions; +my $keywords_file = catfile(updir,'regen','keywords.pl'); +open my $kh, $keywords_file + or die "$0 cannot open $keywords_file: $!"; +while(<$kh>) { + if (m?__END__?..${\0} and /^[+-]/) { + chomp(my $word = $'); + if($& eq '+' || $unsupported{$word}) { + $tests ++; + ok !defined &{\&{"CORE::$word"}}, "no CORE::$word"; + } + else { + $tests += 3; + + my $proto = prototype "CORE::$word"; + *{"my$word"} = \&{"CORE::$word"}; + is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word"; + + CORE::state $protochar = qr/\G([^\\]|\\(?:[^[]|\[[^]]+\]))/; + my $numargs = + () = $proto =~ s/;.*//r =~ /$protochar/g; + my $code = + "#line 1 This-line-makes-__FILE__-easier-to-test. + sub { () = (my$word(" + . ($args_for{$word} || join ",", map "\$$_", 1..$numargs) + . "))}"; + my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die); + my $my = $bd->coderef2text(eval $code or die); + is $my, $core, "inlinability of CORE::$word with parens"; + + $code = + "#line 1 This-line-makes-__FILE__-easier-to-test. + sub { () = (my$word " + . ($args_for{$word} || join ",", map "\$$_", 1..$numargs) + . ")}"; + $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die); + $my = $bd->coderef2text(eval $code or die); + is $my, $core, "inlinability of CORE::$word without parens"; + + next if ($proto =~ /\@/); + # These ops currently accept any number of args, despite their + # prototypes, if they have any: + next if $word =~ /^(?:chom?p|exec|keys|each|read(?:lin|pip)e|reset + |system|values|l?stat)/x; + + $tests ++; + $code = + "sub { () = (my$word(" + . ( + $args_for{$word} + ? $args_for{$word}.',$7' + : join ",", map "\$$_", 1..$numargs+5+( + $proto =~ /;/ + ? () = $' =~ /$protochar/g + : 0 + ) + ) + . "))}"; + eval $code; + like $@, qr/^Too many arguments for $word/, + "inlined CORE::$word with too many args" + or warn $code; + + } + } +} + +is curr_test, $tests+1, 'right number of tests'; +done_testing; + +CORE::__END__ |