From: Father Chrysostomos Date: Thu, 25 Aug 2011 16:50:02 +0000 (-0700) Subject: Allow ampersand calls for CORE subs with $*$$**$ protos X-Git-Tag: accepted/trunk/20130322.191538~3025 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=c931b03652afbc6f3525df91e6f1b821bf7c9fe3;p=platform%2Fupstream%2Fperl.git 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 --- 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 --- 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 --- 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 --- 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, '¬'; lis [&mynot(0)], [!0], '¬ 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;