&CORE::foo() for @ and $@ prototypes, except unlink

This commit allows the CORE subroutines for functions with @
and $@ prototypes to be called through references and via amper-
sand syntax.

unlink is not included in this commit, as it requires special casing
due to its use of implicit $_.

Since these functions require a pushmark, and since it has to come
between two things that pp_coreargs does, it’s easiest to flag the
coreargs op (with the OPpCOREARGS_PUSHMARK flag added in the previous
commit) and call pp_pushmark directly from pp_coreargs.

diff --git a/gv.c b/gv.c
index 2b469ec..e695f7a 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1352,27 +1352,26 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            case KEY_or: case KEY_x: case KEY_xor:
                return gv;
            case KEY_chdir:
-           case KEY_chmod: case KEY_chomp: case KEY_chop: case KEY_chown:
+           case KEY_chomp: case KEY_chop:
            case KEY_close:
-           case KEY_dbmclose: case KEY_dbmopen: case KEY_die:
+           case KEY_dbmclose: case KEY_dbmopen:
            case KEY_each: case KEY_eof: case KEY_exec: case KEY_exit:
-           case KEY_formline: case KEY_getc: case KEY_getpgrp:
-           case KEY_gmtime: case KEY_index: case KEY_join:
-           case KEY_keys: case KEY_kill:
+           case KEY_getc: case KEY_getpgrp: case KEY_gmtime:
+           case KEY_index: case KEY_keys:
            case KEY_localtime: case KEY_lock: case KEY_lstat:
-           case KEY_mkdir: case KEY_open: case KEY_pack: case KEY_pop:
+           case KEY_mkdir: case KEY_open: case KEY_pop:
            case KEY_push: case KEY_rand: case KEY_read: case KEY_readline:
-           case KEY_recv: case KEY_reset: case KEY_reverse:
+           case KEY_recv: case KEY_reset:
            case KEY_rindex: case KEY_select: case KEY_send:
            case KEY_setpgrp: case KEY_shift: case KEY_sleep:
-           case KEY_splice: case KEY_sprintf:
+           case KEY_splice:
            case KEY_srand: case KEY_stat: case KEY_substr:
-           case KEY_syscall: case KEY_sysopen: case KEY_sysread:
+           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_utime: case KEY_values: case KEY_warn: case KEY_write:
+           case KEY_values: case KEY_write:
                ampable = FALSE;
            }
            if (ampable) {

diff --git a/op.c b/op.c
index 9736758..4f42daa 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3091,6 +3091,13 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
 
     if (!(PL_opargs[type] & OA_MARK))
        op_null(cLISTOPo->op_first);
+    else {
+       OP * const kid2 = cLISTOPo->op_first->op_sibling;
+       if (kid2 && kid2->op_type == OP_COREARGS) {
+           op_null(cLISTOPo->op_first);
+           kid2->op_private |= OPpCOREARGS_PUSHMARK;
+       }
+    }  
 
     o->op_type = (OPCODE)type;
     o->op_ppaddr = PL_ppaddr[type];

diff --git a/pp.c b/pp.c
index 7cffe23..19ba8bc 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -6021,6 +6021,7 @@ PP(pp_coreargs)
     /* Count how many args there are first, to get some idea how far to
        extend the stack. */
     while (oa) {
+       if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
        maxargs++;
        if (oa & OA_OPTIONAL) seen_question = 1;
        if (!seen_question) minargs++;
@@ -6045,7 +6046,15 @@ PP(pp_coreargs)
 
     if(!maxargs) RETURN;
 
-    EXTEND(SP, maxargs);
+    /* We do this here, rather than with a separate pushmark op, as it has
+       to come in between two things this function does (stack reset and
+       arg pushing).  This seems the easiest way to do it. */
+    if (PL_op->op_private & OPpCOREARGS_PUSHMARK) {
+       PUTBACK;
+       (void)Perl_pp_pushmark(aTHX);
+    }
+
+    EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
     PUTBACK; /* The code below can die in various places. */
 
     oa = PL_opargs[opnum] >> OASHIFT;
@@ -6069,6 +6078,12 @@ PP(pp_coreargs)
        case OA_SCALAR:
            PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
            break;
+       case OA_LIST:
+           while (numargs--) {
+               PUSHs(svp && *svp ? *svp : &PL_sv_undef);
+               svp++;
+           }
+           RETURN;
        case OA_FILEREF:
            if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
                /* no magic here, as the prototype will have added an extra

diff --git a/pp_hot.c b/pp_hot.c
index fbe195f..b75b263 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -74,6 +74,7 @@ PP(pp_null)
     return NORMAL;
 }
 
+/* This is sometimes called directly by pp_coreargs. */
 PP(pp_pushmark)
 {
     dVAR;

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 799d357..40e7aa9 100644 (file)
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -26,6 +26,7 @@ sub lis($$;$) {
 }
 
 my %op_desc = (
+ join     => 'join or string',
  readpipe => 'quoted execution (``, qx)',
  ref      => 'reference-type operator',
 );
@@ -122,6 +123,16 @@ sub test_proto {
     eval " &CORE::$o((1)x($maxargs+1)) ";
     like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
   }
+  elsif ($p eq '@') {
+    # Do nothing, as we cannot test for too few or too many arguments.
+  }
+  elsif ($p eq '$@') {
+    $tests ++;    
+    eval " &CORE::$o() ";
+    my $desc = quotemeta op_desc($o);
+    like $@, qr/^Not enough arguments for $desc at /,
+       "&$o with too few args";
+  }
 
   else {
     die "Please add tests for the $p prototype";
@@ -203,6 +214,19 @@ sub {
    ::caller_test();
 }->();
 
+test_proto 'chmod';
+$tests += 3;
+is &CORE::chmod(), 0, '&chmod with no args';
+is &CORE::chmod(0666), 0, '&chmod';
+lis [&CORE::chmod(0666)], [0], '&chmod in list context';
+
+test_proto 'chown';
+$tests += 4;
+is &CORE::chown(), 0, '&chown with no args';
+is &CORE::chown(1), 0, '&chown with 1 arg';
+is &CORE::chown(1,2), 0, '&chown';
+lis [&CORE::chown(1,2)], [0], '&chown in list context';
+
 test_proto 'chr', 5, "\5";
 test_proto 'chroot';
 
@@ -228,11 +252,22 @@ CORE::given(1) {
 test_proto 'cos';
 test_proto 'crypt';
 
+test_proto 'die';
+eval { dier('quinquangle') };
+is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++;
+
 test_proto $_ for qw(
  endgrent endhostent endnetent endprotoent endpwent endservent
 );
 
 test_proto 'fork';
+
+test_proto 'formline';
+$tests += 3;
+is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval';
+is $^A,        ' 1       2', 'effect of &myformline';
+lis [&myformline('@')], [1], '&myformline in list context';
+
 test_proto 'exp';
 test_proto 'fcntl';
 
@@ -253,6 +288,18 @@ test_proto "get$_" for qw '
 test_proto 'hex', ff=>255;
 test_proto 'int', 1.5=>1;
 test_proto 'ioctl';
+
+test_proto 'join';
+$tests += 2;
+is &myjoin('a','b','c'), 'bac', '&join';
+lis [&myjoin('a','b','c')], ['bac'], '&join in list context';
+
+test_proto 'kill'; # set up mykill alias
+if ($^O ne 'riscos') {
+    $tests ++;
+    ok( &mykill(0, $$), '&kill' );
+}
+
 test_proto 'lc', 'A', 'a';
 test_proto 'lcfirst', 'AA', 'aA';
 test_proto 'length', 'aaa', 3;
@@ -269,6 +316,12 @@ lis [&mynot(0)], [!0], '&not in list context';
 test_proto 'oct', '666', 438;
 test_proto 'opendir';
 test_proto 'ord', chr(64), 64;
+
+test_proto 'pack';
+$tests += 2;
+is &mypack("H*", '5065726c'), 'Perl', '&pack';
+lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context';
+
 test_proto 'pipe';
 test_proto 'quotemeta', '$', '\$';
 test_proto 'readdir';
@@ -291,6 +344,13 @@ test_proto 'rename';
 }
 
 test_proto 'ref', [], 'ARRAY';
+
+test_proto 'reverse';
+$tests += 2;
+is &myreverse('reward'), 'drawer', '&reverse';
+lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'],
+  '&reverse in list context';
+
 test_proto 'rewinddir';
 test_proto 'rmdir';
 
@@ -314,8 +374,15 @@ test_proto "shm$_" for qw "ctl get read write";
 test_proto 'shutdown';
 test_proto 'sin';
 test_proto "socket$_" for "", "pair";
+
+test_proto 'sprintf';
+$tests += 2;
+is &mysprintf("%x", 65), '41', '&sprintf';
+lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context';
+
 test_proto 'sqrt', 4, 2;
 test_proto 'symlink';
+test_proto 'syscall';
 test_proto 'sysseek';
 test_proto 'telldir';
 
@@ -333,6 +400,11 @@ like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
 test_proto 'uc', 'aa', 'AA';
 test_proto 'ucfirst', 'aa', "Aa";
 
+test_proto 'utime';
+$tests += 2;
+is &myutime(undef,undef), 0, '&utime';
+lis [&myutime(undef,undef)], [0], '&utime in list context';
+
 test_proto 'vec';
 $tests += 3;
 is &myvec("foo", 0, 4), 6, '&vec';
@@ -358,6 +430,15 @@ is($context, 'scalar', '&wantarray with caller in scalar context');
 is($context, 'void', '&wantarray with caller in void context');
 lis [&mywantarray],[wantarray], '&wantarray itself in list context';
 
+test_proto 'warn';
+{ $tests += 3;
+  my $w;
+  local $SIG{__WARN__} = sub { $w = shift };
+  is &mywarn('a'), 1, '&warn retval';
+  is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning';
+  lis [&mywarn()], [1], '&warn retval in list context';
+}
+
 # This is just a check to make sure we have tested everything.  If we
 # haven’t, then either the sub needs to be tested or the list in
 # gv.c is wrong.
@@ -394,6 +475,7 @@ done_testing;
 
 sub file { &CORE::__FILE__ }
 sub line { &CORE::__LINE__ } # 5
+sub dier { &CORE::die(@_)  } # 6
 package stribble;
 sub main::pakg { &CORE::__PACKAGE__ }