diff options
| -rw-r--r-- | gv.c | 5 | ||||
| -rw-r--r-- | pp.c | 3 | ||||
| -rw-r--r-- | pp_hot.c | 10 | ||||
| -rw-r--r-- | pp_sys.c | 6 | ||||
| -rw-r--r-- | t/op/coresubs.t | 77 |
5 files changed, 91 insertions, 10 deletions
@@ -1353,14 +1353,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return gv; case KEY_chdir: case KEY_chomp: case KEY_chop: - case KEY_close: case KEY_dbmclose: case KEY_dbmopen: case KEY_each: case KEY_eof: case KEY_exec: case KEY_exit: - case KEY_getc: case KEY_getpgrp: case KEY_gmtime: + 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_pop: - case KEY_push: case KEY_rand: case KEY_read: case KEY_readline: + case KEY_push: case KEY_rand: case KEY_read: case KEY_recv: case KEY_reset: case KEY_rindex: case KEY_select: case KEY_send: case KEY_setpgrp: case KEY_shift: case KEY_sleep: @@ -6085,7 +6085,8 @@ PP(pp_coreargs) } RETURN; case OA_FILEREF: - if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp))) + if (!numargs) PUSHs(NULL); + else 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)); @@ -322,9 +322,13 @@ PP(pp_padsv) PP(pp_readline) { dVAR; - dSP; SvGETMAGIC(TOPs); - tryAMAGICunTARGET(iter_amg, 0, 0); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + dSP; + if (TOPs) { + SvGETMAGIC(TOPs); + tryAMAGICunTARGET(iter_amg, 0, 0); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + } + else PL_last_in_gv = PL_argvgv, PL_stack_sp--; if (!isGV_with_GP(PL_last_in_gv)) { if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv)); @@ -631,7 +631,8 @@ PP(pp_open) PP(pp_close) { dVAR; dSP; - GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs); + GV * const gv = + MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); if (MAXARG == 0) EXTEND(SP, 1); @@ -1253,7 +1254,8 @@ PP(pp_select) PP(pp_getc) { dVAR; dSP; dTARGET; - GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs); + GV * const gv = + MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); IO *const io = GvIO(gv); if (MAXARG == 0) diff --git a/t/op/coresubs.t b/t/op/coresubs.t index 40e7aa9a89..a3c1eb3dec 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -27,6 +27,7 @@ sub lis($$;$) { my %op_desc = ( join => 'join or string', + readline => '<HANDLE>', readpipe => 'quoted execution (``, qx)', ref => 'reference-type operator', ); @@ -104,7 +105,9 @@ sub test_proto { my $maxargs = length $1; $tests += 1; eval " &CORE::$o((1)x($maxargs+1)) "; - like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; + my $desc = quotemeta op_desc($o); + like $@, qr/^Too many arguments for $desc at /, + "&$o with too many args"; } elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or *** my $args = length $1; @@ -230,6 +233,31 @@ lis [&CORE::chown(1,2)], [0], '&chown in list context'; test_proto 'chr', 5, "\5"; test_proto 'chroot'; +test_proto 'close'; +{ + last if is_miniperl; + $tests += 3; + + open my $fh, ">", \my $buffalo; + print $fh 'an address in the outskirts of Jersey'; + ok &CORE::close($fh), '&CORE::close retval'; + print $fh 'lalala'; + is $buffalo, 'an address in the outskirts of Jersey', + 'effect of &CORE::close'; + # This has to be a separate variable from $fh, as re-using the same + # variable can cause the tests to pass by accident. That actually hap- + # pened during developement, because the second close() was reading + # beyond the end of the stack and finding a $fh left over from before. + open my $fh2, ">", \($buffalo = ''); + select+(select($fh2), do { + print "Nasusiro Tokasoni"; + &CORE::close(); + print "jfd"; + is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args'; + })[0]; +} +lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests; + test_proto 'closedir'; $tests += 2; is &CORE::closedir(foo), undef, '&CORE::closedir'; @@ -279,6 +307,18 @@ lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx'; test_proto 'flock'; test_proto 'fork'; +test_proto 'getc'; +{ + last if is_miniperl; + $tests += 3; + local *STDIN; + open my $fh, "<", \(my $buf='falo'); + open STDIN, "<", \(my $buf2 = 'bison'); + is &mygetc($fh), 'f', '&mygetc'; + is &mygetc(), 'b', '&mygetc with no args'; + lis [&mygetc($fh)], ['a'], '&mygetc in list context'; +} + test_proto "get$_" for qw ' grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname netent peername ppid priority protobyname protobynumber protoent @@ -325,6 +365,32 @@ lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context'; test_proto 'pipe'; test_proto 'quotemeta', '$', '\$'; test_proto 'readdir'; + +test_proto 'readline'; +{ + local *ARGV = *DATA; + $tests ++; + is scalar &myreadline, + "I wandered lonely as a cloud\n", '&readline w/no args'; +} +{ + last if is_miniperl; + $tests += 2; + open my $fh, "<", \(my $buff = <<END); +The Recursive Problem +--------------------- +I have a problem I cannot solve. +The problem is that I cannot solve it. +END + is &myreadline($fh), "The Recursive Problem\n", + '&readline with 1 arg'; + lis [&myreadline($fh)], [ + "---------------------\n", + "I have a problem I cannot solve.\n", + "The problem is that I cannot solve it.\n", + ], '&readline in list context'; +} + test_proto 'readlink'; test_proto 'readpipe'; @@ -480,3 +546,12 @@ package stribble; sub main::pakg { &CORE::__PACKAGE__ } # Please do not add new tests here. +package main; +CORE::__DATA__ +I wandered lonely as a cloud +That floats on high o’er vales and hills, +And all at once I saw a crowd, +A host of golden daffodils! +Beside the lake, beneath the trees, +Fluttering, dancing, in the breeze. +-- Wordsworth |