- if (strnEQ(stashname, "CORE", 4)) {
- const int code = keyword(name, len, 1);
- static const char file[] = __FILE__;
- CV *cv, *oldcompcv;
- int opnum = 0;
- SV *opnumsv;
- bool ampable = TRUE; /* &{}-able */
- COP *oldcurcop;
- yy_parser *oldparser;
- I32 oldsavestack_ix;
-
- if (code >= 0) return gv; /* 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 gv;
- 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_read:
- case KEY_recv: case KEY_reset:
- case KEY_select: case KEY_send:
- case KEY_setpgrp: case KEY_shift: case KEY_sleep:
- case KEY_splice:
- case KEY_srand: case KEY_stat: case KEY_substr:
- case KEY_sysopen: case KEY_sysread:
- case KEY_system: case KEY_syswrite:
- case KEY_tell: case KEY_tie: case KEY_tied:
- case KEY_truncate: case KEY_umask: case KEY_unlink:
- case KEY_unpack: case KEY_unshift: case KEY_untie:
- case KEY_values: case KEY_write:
- ampable = FALSE;
- }
- 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 (ampable) {
- if (opnum == OP_VEC || opnum == OP_LOCK) CvLVALUE_on(cv);
- newATTRSUB(oldsavestack_ix,
- newSVOP(
- OP_CONST, 0,
- newSVpvn_share(nambeg,full_len,0)
- ),
- NULL,NULL,
- coresub_op(
- opnum
- ? newSVuv((UV)opnum)
- : newSVpvn(name,len),
- code, opnum
- )
- );
- assert(GvCV(gv) == cv);
- if (opnum == OP_LOCK)
- 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);
- }