Enable ampersand calls to CORE subs with $$$ prototypes

This applies to functions that just take plain scalar arguments, all
of which are mandatory.  Functions that take optional arguments are
not supported yet. truncate() is not supported yet, either (its $$
prototype is not entirely veracious).

This commit enables those functions to be called via &CORE::foo() syn-
tax or through references.

You can now encrypt a string like this: "string"->CORE::crypt($salt).

Each function’s op tree is like this:

$ ./perl -Ilib -MO=Concise,CORE::atan2 -e 'BEGIN{\&CORE::atan2}'
CORE::atan2:
3  <1> leavesub[1 ref] K/REFC,1 ->(end)
2     <@> atan2[t1] sK ->3
-        <0> ex-pushmark s ->1
1        <$> coreargs(IV 100) s ->2
-e syntax OK

This commit adds code to ck_fun to skip the argument check if
coresubs is present.  Otherwise we get a ‘Not enough arguments for
atan2’ error.

diff --git a/gv.c b/gv.c
index 311017e..c8168b5 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1352,22 +1352,34 @@ 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___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
-           case KEY_abs: case KEY_alarm: case KEY_chr: case KEY_chroot:
+           case KEY_abs: case KEY_alarm: case KEY_atan2: case KEY_chr:
+           case KEY_chroot: case KEY_crypt:
            case KEY_break: case KEY_continue: case KEY_cos:
            case KEY_endgrent: case KEY_endhostent:
            case KEY_endnetent: case KEY_endprotoent: case KEY_endpwent:
-           case KEY_endservent: case KEY_exp:
-           case KEY_getgrent: case KEY_gethostent:
-           case KEY_fork:
-           case KEY_getlogin: case KEY_getnetent: case KEY_getppid:
-           case KEY_getprotoent: case KEY_getservent: case KEY_getpwent:
+           case KEY_endservent: case KEY_exp: case KEY_fork:
+           case KEY_getgrent: case KEY_getgrgid: case KEY_getgrnam:
+           case KEY_gethostbyaddr: case KEY_gethostbyname:
+           case KEY_gethostent: case KEY_getlogin: case KEY_getnetbyaddr:
+           case KEY_getnetbyname: case KEY_getnetent: case KEY_getppid:
+           case KEY_getpriority: case KEY_getprotobyname:
+           case KEY_getprotobynumber: case KEY_getprotoent:
+           case KEY_getpwnam: case KEY_getpwuid: case KEY_getservbyname:
+           case KEY_getservbyport: case KEY_getservent: case KEY_getpwent:
            case KEY_hex: case KEY_int: case KEY_lc: case KEY_lcfirst: 
-           case KEY_length: case KEY_log: case KEY_oct: case KEY_ord:
+           case KEY_length: case KEY_link: case KEY_log: case KEY_msgctl:
+           case KEY_msgget: case KEY_msgrcv: case KEY_msgsnd:
+           case KEY_not: case KEY_oct: case KEY_ord:
            case KEY_quotemeta: case KEY_readlink: case KEY_readpipe:
-           case KEY_ref: case KEY_rmdir: case KEY_setgrent:
-           case KEY_setpwent: case KEY_sin: case KEY_sqrt: case KEY_time:
-           case KEY_times: case KEY_uc: case KEY_ucfirst:
-           case KEY_wait: case KEY_wantarray:
+           case KEY_ref: case KEY_rename: case KEY_rmdir: case KEY_semctl:
+           case KEY_semget: case KEY_semop: case KEY_setgrent:
+           case KEY_sethostent: case KEY_setnetent: case KEY_setpriority:
+           case KEY_setprotoent: case KEY_setpwent: case KEY_setservent:
+           case KEY_shmctl: case KEY_shmget: case KEY_shmread:
+           case KEY_shmwrite: case KEY_sin: case KEY_sqrt:
+           case KEY_symlink: case KEY_time: case KEY_times:
+           case KEY_uc: case KEY_ucfirst: case KEY_vec:
+           case KEY_wait: case KEY_waitpid: case KEY_wantarray:
                ampable = TRUE;
            }
            if (ampable) {
@@ -1401,6 +1413,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                   new ATTRSUB. */
            (void)core_prototype((SV *)cv, name, code, &opnum);
            if (ampable) {
+               if (opnum == OP_VEC) CvLVALUE_on(cv);
                newATTRSUB(oldsavestack_ix,
                           newSVOP(
                                 OP_CONST, 0,

diff --git a/op.c b/op.c
index 1ca495c..4577bcc 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7685,6 +7685,7 @@ Perl_ck_fun(pTHX_ OP *o)
            tokid = &kid->op_sibling;
            kid = kid->op_sibling;
        }
+       if (kid && kid->op_type == OP_COREARGS) return o;
 
        while (oa) {
            if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
@@ -10351,8 +10352,10 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
                        newOP(opnum,
                              opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
                   );
-       default:
+       case OA_BASEOP_OR_UNOP:
            return newUNOP(opnum,0,argop);
+       default:
+           return convert(opnum,0,argop);
        }
     }
 }

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 1866c0d..a17bef5 100644 (file)
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -99,6 +99,14 @@ sub test_proto {
        is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval"
     };   
   }
+  elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
+    my $args = length $1;
+    $tests += 2;    
+    eval " &CORE::$o((1)x($args-1)) ";
+    like $@, qr/^Not enough arguments for $o at /, "&$o with too few args";
+    eval " &CORE::$o((1)x($args+1)) ";
+    like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+  }
 
   else {
     die "Please add tests for the $p prototype";
@@ -115,6 +123,7 @@ is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
 
 test_proto 'abs', -5, 5;
 test_proto 'alarm';
+test_proto 'atan2';
 
 test_proto 'break';
 { $tests ++;
@@ -140,6 +149,7 @@ CORE::given(1) {
 }
 
 test_proto 'cos';
+test_proto 'crypt';
 
 test_proto $_ for qw(
  endgrent endhostent endnetent endprotoent endpwent endservent
@@ -149,9 +159,9 @@ test_proto 'fork';
 test_proto 'exp';
 
 test_proto "get$_" for qw '
-  grent hostent login
-  netent ppid protoent
-  pwent servent
+  grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
+  netent ppid priority protobyname protobynumber protoent
+  pwent pwnam pwuid servbyname servbyport servent
 ';
 
 test_proto 'hex', ff=>255;
@@ -159,21 +169,48 @@ test_proto 'int', 1.5=>1;
 test_proto 'lc', 'A', 'a';
 test_proto 'lcfirst', 'AA', 'aA';
 test_proto 'length', 'aaa', 3;
+test_proto 'link';
 test_proto 'log';
+test_proto "msg$_" for qw( ctl get rcv snd );
+
+test_proto 'not';
+$tests += 2;
+is &mynot(1), !1, '&not';
+lis [&mynot(0)], [!0], '&not in list context';
+
 test_proto 'oct', '666', 438;
 test_proto 'ord', chr(64), 64;
 test_proto 'quotemeta', '$', '\$';
 test_proto 'readlink';
 test_proto 'readpipe';
+
+use if !is_miniperl, File::Spec::Functions, qw "catfile";
+use if !is_miniperl, File::Temp, 'tempdir';
+
+test_proto 'rename';
+{
+    last if is_miniperl;
+    $tests ++;
+    my $dir = tempdir(uc cleanup => 1);
+    my $tmpfilenam = catfile $dir, 'aaa';
+    open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!";
+    close $fh or die "cannot close $tmpfilenam: $!";
+    &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb');
+    ok open(my $fh, '>', $tmpfilenam), '&rename';
+}
+
 test_proto 'ref', [], 'ARRAY';
 test_proto 'rmdir';
+test_proto "sem$_" for qw "ctl get op";
 
 test_proto "set$_" for qw '
-  grent pwent
+  grent hostent netent priority protoent pwent servent
 ';
 
+test_proto "shm$_" for qw "ctl get read write";
 test_proto 'sin';
 test_proto 'sqrt', 4, 2;
+test_proto 'symlink';
 
 test_proto 'time';
 $tests += 2;
@@ -188,7 +225,17 @@ like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
 
 test_proto 'uc', 'aa', 'AA';
 test_proto 'ucfirst', 'aa', "Aa";
+
+test_proto 'vec';
+$tests += 3;
+is &myvec("foo", 0, 4), 6, '&vec';
+lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
+$tmp = "foo";
+++&myvec($tmp,0,4);
+is $tmp, "goo", 'lvalue &vec';
+
 test_proto 'wait';
+test_proto 'waitpid';
 
 test_proto 'wantarray';
 $tests += 4;