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/coresubs.t Test &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
if (strnEQ(stashname, "CORE", 4)) {
const int code = keyword(name, len, 1);
static const char file[] = __FILE__;
- CV *cv;
+ CV *cv, *oldcompcv;
int opnum = 0;
SV *opnumsv;
+ bool ampable = FALSE; /* &{}-able */
+ OP *o;
+ 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 */
- switch (-code) {
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___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
+ case KEY_continue: case KEY_endgrent: case KEY_endhostent:
+ case KEY_endnetent: case KEY_endprotoent: case KEY_endpwent:
+ case KEY_endservent: case KEY_getgrent: case KEY_gethostent:
+ case KEY_getlogin: case KEY_getnetent: case KEY_getppid:
+ case KEY_getprotoent: case KEY_getservent: case KEY_setgrent:
+ case KEY_setpwent: case KEY_time: case KEY_times:
+ case KEY_wait:
+ ampable = TRUE;
}
- /* 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);
+ 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;
- CvISXSUB_on(cv);
- CvXSUB(cv) = core_xsub;
+ /* 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) {
+ OP * const argop =
+ newSVOP(OP_COREARGS,0,
+ opnum ? newSVuv((UV)opnum) : newSVpvn(name,len));
+ switch(opnum) {
+ case 0:
+ {
+ IV index = 0;
+ switch(-code) {
+ case KEY___FILE__ : index = 1; break;
+ case KEY___LINE__ : index = 2; break;
+ }
+ o = op_append_elem(OP_LINESEQ,
+ argop,
+ newSLICEOP(0,
+ newSVOP(OP_CONST, 0,
+ newSViv(index)
+ ),
+ newOP(OP_CALLER,0)
+ )
+ );
+ break;
+ }
+ default:
+ o = op_append_elem(OP_LINESEQ, argop, newOP(opnum,0));
+ }
+ newATTRSUB(oldsavestack_ix,
+ newSVOP(
+ OP_CONST, 0,
+ newSVpvn_share(nambeg,full_len,0)
+ ),
+ NULL,NULL,o
+ );
+ assert(GvCV(gv) == cv);
+ 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
PP(pp_coreargs)
{
dSP;
+ int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
+ AV * const at_ = GvAV(PL_defgv);
+ I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
+ I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
+ const char *err = NULL;
+
+ /* Count how many args there are. */
+ while (oa) {
+ maxargs++;
+ oa >>= 4;
+ }
+
+ if(numargs < minargs) err = "Not enough";
+ else if(numargs > maxargs) err = "Too many";
+ if (err)
+ /* diag_listed_as: Too many arguments for %s */
+ Perl_croak(aTHX_
+ "%s arguments for %s", err,
+ opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
+ );
+
+ /* Reset the stack pointer. Without this, we end up returning our own
+ arguments in list context, in addition to the values we are supposed
+ to return. nextstate usually does this on sub entry, but we need
+ to run the next op with the caller’s hints, so we cannot have a
+ nextstate. */
+ SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+
RETURN;
}
#!./perl
+# This script tests the inlining of CORE:: subs. Since it’s convenient
+# (this script reads the list in keywords.pl), we also test that prototypes
+# match the built-ins and check for undefinedness.
+
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
--- /dev/null
+#!./perl
+
+# This file tests the results of calling subroutines in the CORE::
+# namespace with ampersand syntax. In other words, it tests the bodies of
+# the subroutines themselves, not the ops that they might inline themselves
+# as when called as barewords.
+
+# coreinline.t tests the inlining of these subs as ops. Since it was
+# convenient, I also put the prototype and undefinedness checking in that
+# file, even though those have nothing to do with inlining. (coreinline.t
+# reads the list in keywords.pl, which is why it’s convenient.)
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+ require "test.pl";
+ $^P |= 0x100;
+}
+# Since tests inside evals can too easily fail silently, we cannot rely
+# on done_testing. It’s much easier to count the tests as we go than to
+# declare the plan up front, so this script ends with a test that makes
+# sure the right number of tests have happened.
+
+sub lis($$;$) {
+ &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
+}
+
+# This tests that the &{} syntax respects the number of arguments implied
+# by the prototype.
+sub test_proto {
+ my($o) = shift;
+
+ # Create an alias, for the caller’s convenience.
+ *{"my$o"} = \&{"CORE::$o"};
+
+ my $p = prototype "CORE::$o";
+
+ if ($p eq '') {
+ $tests ++;
+
+ eval " &CORE::$o(1) ";
+ like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+
+ }
+
+ else {
+ die "Please add tests for the $p prototype";
+ }
+}
+
+test_proto '__FILE__';
+test_proto '__LINE__';
+test_proto '__PACKAGE__';
+
+is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests;
+is line(), 5 , '__LINE__ does check its caller' ; ++ $tests;
+is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
+
+test_proto 'continue';
+$tests ++;
+CORE::given(1) {
+ CORE::when(1) {
+ &mycontinue();
+ }
+ pass "&continue";
+}
+
+test_proto $_ for qw(
+ endgrent endhostent endnetent endprotoent endpwent endservent
+);
+
+test_proto "get$_" for qw '
+ grent hostent login
+ netent ppid protoent
+ servent
+';
+
+test_proto "set$_" for qw '
+ grent pwent
+';
+
+test_proto 'time';
+$tests += 2;
+like &mytime, '^\d+\z', '&time in scalar context';
+like join('-', &mytime), '^\d+\z', '&time in list context';
+
+test_proto 'times';
+$tests += 2;
+like &mytimes, '^[\d.]+\z', '× in scalar context';
+like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
+ '× in list context';
+
+test_proto 'wait';
+
+
+# Add new tests above this line.
+
+# ------------ END TESTING ----------- #
+
+is curr_test, $tests+1, 'right number of tests';
+done_testing;
+
+#line 3 frob
+
+sub file { &CORE::__FILE__ }
+sub line { &CORE::__LINE__ } # 5
+package stribble;
+sub main::pakg { &CORE::__PACKAGE__ }
+
+# Please do not add new tests here.