&CORE::foo() for nullary functions
authorFather Chrysostomos <sprout@cpan.org>
Wed, 17 Aug 2011 19:32:33 +0000 (12:32 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 18 Aug 2011 13:50:20 +0000 (06:50 -0700)
This commit makes nullary subs in the CORE package callable with
ampersand syntax and through references--except for wantarray, which
is more complicated and will have its own commit.

It does this by creating an op tree like this:

$ ./perl -Ilib -MO=Concise,CORE::times -e 'BEGIN{\&CORE::times}'
CORE::times:
3  <1> leavesub[1 ref] K/REFC,1 ->(end)
-     <@> lineseq K ->3
1        <$> coreargs(IV 310) v ->2
2        <0> tms ->3
-e syntax OK

The coreargs op checks to make sure there are no arguments, for now.
The 310 is the op number for times (OP_TMS).

There is no nextstate op, because we want to inherit hints from
the caller.

The __FILE__, __LINE__ and __PACKAGE__ directives are implemented
like this:

$ ./perl -Ilib -MO=Concise,CORE::__FILE__ -e 'BEGIN{\&CORE::__FILE__}'
CORE::__FILE__:
7  <1> leavesub[1 ref] K/REFC,1 ->(end)
-     <@> lineseq K ->7
1        <$> coreargs(PV "__FILE__") v ->2
6        <2> lslice K/2 ->7
-           <1> ex-list lK ->4
2              <0> pushmark s ->3
3              <$> const(IV 1) s ->4
-           <1> ex-list lK ->6
4              <0> pushmark s ->5
5              <0> caller[t1] l ->6
-e syntax OK

The lslice op and its children are equivalent to (caller)[1].

MANIFEST
gv.c
pp.c
t/op/coreinline.t
t/op/coresubs.t [new file with mode: 0644]

index 8e999d7ca48caff0e16b4c87fbe81eb27af4832d..9c81b29ace9bbe0bc9f0d9d61c39c4a9e880dea5 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4918,6 +4918,7 @@ 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/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
diff --git a/gv.c b/gv.c
index aa306c81a93293df20aed91f2cc15648bffea275..6c9cf936b418854c69b6b42dcf9298921bd9950c 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1333,32 +1333,104 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
          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
diff --git a/pp.c b/pp.c
index b1520bad6a18f9b9d9a538b3a0b7c3f0489f5595..7bf6d6eda2dd27ea4b5e8fc09da62f6464317b7a 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -5967,6 +5967,34 @@ PP(pp_boolkeys)
 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;
 }
 
index fb5c44e5647b8640214896dea486c3a64061d2c5..34ae9e23ed03298c3858c9fc728fee0be8f1d211 100644 (file)
@@ -1,5 +1,9 @@
 #!./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);
diff --git a/t/op/coresubs.t b/t/op/coresubs.t
new file mode 100644 (file)
index 0000000..71e030a
--- /dev/null
@@ -0,0 +1,110 @@
+#!./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', '&times in scalar context';
+like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
+   '&times 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.