summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gv.c29
-rw-r--r--op.c12
-rw-r--r--pp.c19
-rw-r--r--t/op/coresubs.t72
4 files changed, 108 insertions, 24 deletions
diff --git a/gv.c b/gv.c
index c630d08d2e..da66c10eb3 100644
--- 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 4577bcc54f..606e086825 100644
--- 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 5ea531367f..302b5cc37e 100644
--- 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 b744a3538d..1bbd56ab67 100644
--- 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;
View Lorry Controller Status