Add inlinable &CORE::functions

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index aef0aa4..8c2c1f1 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -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