+static void core_xsub(pTHX_ CV* cv);
+
+static GV *
+S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
+ const char * const name, const STRLEN len,
+ const char * const fullname, STRLEN const fullen)
+{
+ const int code = keyword(name, len, 1);
+ static const char file[] = __FILE__;
+ CV *cv, *oldcompcv = NULL;
+ int opnum = 0;
+ SV *opnumsv;
+ bool ampable = TRUE; /* &{}-able */
+ COP *oldcurcop = NULL;
+ yy_parser *oldparser = NULL;
+ I32 oldsavestack_ix = 0;
+
+ assert(gv || stash);
+ assert(name);
+ assert(stash || fullname);
+
+ if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
+ that would require
+ inlining newATTRSUB */
+ if (code >= 0) return NULL; /* not overridable */
+ switch (-code) {
+ /* no support for \&CORE::infix;
+ no support for funcs that take labels, as their parsing is
+ weird */
+ case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
+ case KEY_eq: case KEY_ge:
+ case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
+ case KEY_or: case KEY_x: case KEY_xor:
+ return NULL;
+ case KEY_chdir:
+ case KEY_chomp: case KEY_chop:
+ case KEY_each: case KEY_eof: case KEY_exec:
+ case KEY_keys:
+ case KEY_lstat:
+ case KEY_pop:
+ case KEY_push:
+ case KEY_shift:
+ case KEY_splice:
+ case KEY_stat:
+ case KEY_system:
+ case KEY_truncate: case KEY_unlink:
+ case KEY_unshift:
+ case KEY_values:
+ ampable = FALSE;
+ }
+ if (!gv) {
+ gv = (GV *)newSV(0);
+ gv_init(gv, stash, name, len, TRUE);
+ }
+ if (ampable) {
+ ENTER;
+ oldcurcop = PL_curcop;
+ oldparser = PL_parser;
+ lex_start(NULL, NULL, 0);
+ oldcompcv = PL_compcv;
+ PL_compcv = NULL; /* Prevent start_subparse from setting
+ CvOUTSIDE. */
+ oldsavestack_ix = start_subparse(FALSE,0);
+ cv = PL_compcv;
+ }
+ else {
+ /* 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));
+ CvISXSUB_on(cv);
+ CvXSUB(cv) = core_xsub;
+ }
+ CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
+ from PL_curcop. */
+ (void)gv_fetchfile(file);
+ CvFILE(cv) = (char *)file;
+ /* XXX This is inefficient, as doing things this order causes
+ a prototype check in newATTRSUB. But we have to do
+ it this order as we need an op number before calling
+ new ATTRSUB. */
+ (void)core_prototype((SV *)cv, name, code, &opnum);
+ if (stash && (fullname || !fullen))
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ if (ampable) {
+ SV *tmpstr;
+ CvLVALUE_on(cv);
+ if (!fullname) {
+ tmpstr = newSVhek(HvENAME_HEK(stash));
+ sv_catpvs(tmpstr, "::");
+ sv_catpvn(tmpstr,name,len);
+ }
+ else tmpstr = newSVpvn_share(fullname,fullen,0);
+ newATTRSUB(oldsavestack_ix,
+ newSVOP(OP_CONST, 0, tmpstr),
+ NULL,NULL,
+ coresub_op(
+ opnum
+ ? newSVuv((UV)opnum)
+ : newSVpvn(name,len),
+ code, opnum
+ )
+ );
+ assert(GvCV(gv) == cv);
+ if (opnum != OP_VEC && opnum != OP_SUBSTR)
+ CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+ LEAVE;
+ PL_parser = oldparser;
+ PL_curcop = oldcurcop;
+ PL_compcv = oldcompcv;
+ }
+ opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
+ cv_set_call_checker(
+ cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
+ );
+ SvREFCNT_dec(opnumsv);
+ return gv;
+}
+
https://perl5.git.perl.org / perl5.git / blobdiff