Allow ampersand calls for CORE subs with $*$$**$ protos

This enables ampersand calls and calls through references for CORE
subs that have * and $ in their prototypes and a fixed number of
arguments.

Usually, the *-prototyped ops have their child ops wrapped in rv2gv’s
(*{}) implicitly.  The rv2gv op is sometimes flagged as an autoviv-
ificatory op, such as the first argument to accept() or open().
S_is_handle_constructor contains the list of ops that turn on
that flag.

This commit makes the coreargs op use a couple of flags to serve the
same purpose.  pp_coreargs itself calls S_rv2gv (split out from
pp_rv2gv recently for precisely this purpose) with arguments based on
its own flags.

Currently the autovivified glob gets a name like main::_GEN_0 instead
of main::$a.  I think we can live with that.

diff --git a/gv.c b/gv.c
index c630d08..da66c10 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1351,31 +1351,26 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            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_accept: case KEY_bind: case KEY_binmode:
+           case KEY_binmode:
            case KEY_bless: case KEY_caller: case KEY_chdir:
            case KEY_chmod: case KEY_chomp: case KEY_chop: case KEY_chown:
-           case KEY_close: case KEY_closedir: case KEY_connect:
+           case KEY_close:
            case KEY_dbmclose: case KEY_dbmopen: case KEY_die:
            case KEY_each: case KEY_eof: case KEY_exec: case KEY_exit:
-           case KEY_fcntl: case KEY_fileno: case KEY_flock:
-           case KEY_formline: case KEY_getc: case KEY_getpeername:
-           case KEY_getpgrp: case KEY_getsockname: case KEY_getsockopt:
-           case KEY_gmtime: case KEY_index: case KEY_ioctl: case KEY_join:
-           case KEY_keys: case KEY_kill: case KEY_listen:
+           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_localtime: case KEY_lock: case KEY_lstat:
-           case KEY_mkdir: case KEY_open: case KEY_opendir: case KEY_pack:
-           case KEY_pipe: case KEY_pop: case KEY_push: case KEY_rand:
-           case KEY_read: case KEY_readdir: case KEY_readline:
+           case KEY_mkdir: case KEY_open: case KEY_pack: 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_rewinddir: case KEY_rindex: case KEY_seek:
-           case KEY_seekdir: case KEY_select: case KEY_send:
-           case KEY_setpgrp: case KEY_setsockopt: case KEY_shift:
-           case KEY_shutdown: case KEY_sleep: case KEY_socket:
-           case KEY_socketpair: case KEY_splice: case KEY_sprintf:
+           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_srand: case KEY_stat: case KEY_substr:
            case KEY_syscall: case KEY_sysopen: case KEY_sysread:
-           case KEY_sysseek: case KEY_system: case KEY_syswrite:
-           case KEY_tell: case KEY_telldir: case KEY_tie: case KEY_tied:
+           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:

diff --git a/op.c b/op.c
index 4577bcc..606e086 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10332,6 +10332,7 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
                       const int opnum)
 {
     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+    OP *o;
 
     PERL_ARGS_ASSERT_CORESUB_OP;
 
@@ -10353,9 +10354,16 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
                              opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
                   );
        case OA_BASEOP_OR_UNOP:
-           return newUNOP(opnum,0,argop);
+           o = newUNOP(opnum,0,argop);
+         onearg:
+           if (is_handle_constructor(o, 1))
+               argop->op_private |= OPpCOREARGS_DEREF1;
+           return o;
        default:
-           return convert(opnum,0,argop);
+           o = convert(opnum,0,argop);
+           if (is_handle_constructor(o, 2))
+               argop->op_private |= OPpCOREARGS_DEREF2;
+           goto onearg;
        }
     }
 }

diff --git a/pp.c b/pp.c
index 5ea5313..302b5cc 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -6010,7 +6010,7 @@ PP(pp_coreargs)
     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
     AV * const at_ = GvAV(PL_defgv);
     SV **svp = AvARRAY(at_);
-    I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
+    I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1, whicharg = 0;
     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
     bool seen_question = 0;
     const char *err = NULL;
@@ -6043,6 +6043,7 @@ PP(pp_coreargs)
     if(!maxargs) RETURN;
 
     EXTEND(SP, maxargs);
+    PUTBACK; /* The code below can die in various places. */
 
     oa = PL_opargs[opnum] >> OASHIFT;
     if (!numargs) {
@@ -6060,12 +6061,26 @@ PP(pp_coreargs)
        oa >>= 4;
     }
     for (;oa;numargs&&(++svp,--numargs)) {
+       whicharg++;
        switch (oa & 7) {
        case OA_SCALAR:
            PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
            break;
+       case OA_FILEREF:
+           if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
+               /* no magic here, as the prototype will have added an extra
+                  refgen and we just want what was there before that */
+               PUSHs(SvRV(*svp));
+           else {
+               const bool constr = PL_op->op_private & whicharg;
+               PUSHs(S_rv2gv(aTHX_
+                   svp && *svp ? *svp : &PL_sv_undef,
+                   constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
+                   !constr
+               ));
+           }
+           break;
        default:
-           PUTBACK;
            DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
        }
        oa = oa >> 4;

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index b744a35..1bbd56a 100644 (file)
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -122,9 +122,34 @@ is line(),  5        , '__LINE__ does check its caller'   ; ++ $tests;
 is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
 
 test_proto 'abs', -5, 5;
+
+test_proto 'accept';
+$tests += 6; eval q{
+  is &CORE::accept(qw{foo bar}), undef, "&accept";
+  lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context";
+
+  &myaccept(my $foo, my $bar);
+  is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument';
+  is $bar, undef, 'CORE::accept does not autovivify its second argument';
+  use strict;
+  undef $foo;
+  eval { 'myaccept'->($foo, $bar) };
+  like $@, qr/^Can't use an undefined value as a symbol reference at/,
+      'CORE::accept will not accept undef 2nd arg under strict';
+  is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict';
+};
+
 test_proto 'alarm';
 test_proto 'atan2';
 
+test_proto 'bind';
+$tests += 3;
+is &CORE::bind('foo', 'bear'), undef, "&bind";
+lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context";
+eval { &mybind(my $foo, "bear") };
+like $@, qr/^Bad symbol for filehandle at/,
+     'CORE::bind dies with undef first arg';
+
 test_proto 'break';
 { $tests ++;
   my $tmp;
@@ -139,6 +164,17 @@ test_proto 'break';
 
 test_proto 'chr', 5, "\5";
 test_proto 'chroot';
+
+test_proto 'closedir';
+$tests += 2;
+is &CORE::closedir(foo), undef, '&CORE::closedir';
+lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context';
+
+test_proto 'connect';
+$tests += 2;
+is &CORE::connect('foo','bar'), undef, '&connect';
+lis [&myconnect('foo','bar')], [undef], '&connect in list context';
+
 test_proto 'continue';
 $tests ++;
 CORE::given(1) {
@@ -157,19 +193,30 @@ test_proto $_ for qw(
 
 test_proto 'fork';
 test_proto 'exp';
+test_proto 'fcntl';
+
+test_proto 'fileno';
+$tests += 2;
+is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno';
+lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx';
+
+test_proto 'flock';
+test_proto 'fork';
 
 test_proto "get$_" for qw '
   grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
-  netent ppid priority protobyname protobynumber protoent
-  pwent pwnam pwuid servbyname servbyport servent
+  netent peername ppid priority protobyname protobynumber protoent
+  pwent pwnam pwuid servbyname servbyport servent sockname sockopt
 ';
 
 test_proto 'hex', ff=>255;
 test_proto 'int', 1.5=>1;
+test_proto 'ioctl';
 test_proto 'lc', 'A', 'a';
 test_proto 'lcfirst', 'AA', 'aA';
 test_proto 'length', 'aaa', 3;
 test_proto 'link';
+test_proto 'listen';
 test_proto 'log';
 test_proto "msg$_" for qw( ctl get rcv snd );
 
@@ -179,8 +226,11 @@ is &mynot(1), !1, '&not';
 lis [&mynot(0)], [!0], '&not in list context';
 
 test_proto 'oct', '666', 438;
+test_proto 'opendir';
 test_proto 'ord', chr(64), 64;
+test_proto 'pipe';
 test_proto 'quotemeta', '$', '\$';
+test_proto 'readdir';
 test_proto 'readlink';
 test_proto 'readpipe';
 
@@ -200,17 +250,33 @@ test_proto 'rename';
 }
 
 test_proto 'ref', [], 'ARRAY';
+test_proto 'rewinddir';
 test_proto 'rmdir';
+
+test_proto 'seek';
+{
+    last if is_miniperl;
+    $tests += 1;
+    open my $fh, "<", \"misled" or die $!;
+    &myseek($fh, 2, 0);
+    is <$fh>, 'sled', '&seek in action';
+}
+
+test_proto 'seekdir';
 test_proto "sem$_" for qw "ctl get op";
 
 test_proto "set$_" for qw '
-  grent hostent netent priority protoent pwent servent
+  grent hostent netent priority protoent pwent servent sockopt
 ';
 
 test_proto "shm$_" for qw "ctl get read write";
+test_proto 'shutdown';
 test_proto 'sin';
+test_proto "socket$_" for "", "pair";
 test_proto 'sqrt', 4, 2;
 test_proto 'symlink';
+test_proto 'sysseek';
+test_proto 'telldir';
 
 test_proto 'time';
 $tests += 2;