diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs index c553987afd73..362bdad9601f 100644 --- a/dist/IO/IO.xs +++ b/dist/IO/IO.xs @@ -553,25 +553,32 @@ PPCODE: if (!ix && GIMME_V != G_LIST) Perl_croak(aTHX_ "Can't call $io->getlines in a scalar context, use $io->getline"); Zero(&myop, 1, UNOP); +#if PERL_VERSION_GE(5,39,6) + myop.op_flags = (ix ? (OPf_WANT_SCALAR | OPf_STACKED) : OPf_WANT_LIST); +#else myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED; +#endif myop.op_ppaddr = PL_ppaddr[OP_READLINE]; myop.op_type = OP_READLINE; - /* I don't know if we need this, but it's correct as far as the control flow - goes. However, if we *do* need it, do we need to set anything else up? */ - myop.op_next = PL_op->op_next; + myop.op_next = NULL; /* return from the runops loop below after 1 op */ /* Sigh, because pp_readline calls pp_rv2gv, and *it* has this wonderful state check for PL_op->op_type == OP_READLINE */ PL_op = (OP *) &myop; io = ST(0); - /* Our target (which we need to provide, as we don't have a pad entry. - I think that this is only needed for G_SCALAR - maybe we can get away - with NULL for list context? */ - PUSHs(sv_newmortal()); + /* For scalar functions (getline/gets), provide a target on the stack, + * as we don't have a pad entry. */ +#if PERL_VERSION_GE(5,39,6) + if (ix) +#endif + PUSHs(sv_newmortal()); XPUSHs(io); PUTBACK; + /* call a new runops loop for just the one op rather than just calling + * pp_readline directly, as the former will handle the call coming + * from a ref-counted stack */ /* And effectively we get away with tail calling pp_readline, as it stacks exactly the return value(s) we need to return. */ - PL_ppaddr[OP_READLINE](aTHX); + CALLRUNOPS(aTHX); PL_op = was; /* And we don't want to reach the line PL_stack_sp = sp; diff --git a/gv.c b/gv.c index 93fc37da63a5..de1d554b6886 100644 --- a/gv.c +++ b/gv.c @@ -4195,6 +4195,13 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) res = newSV_type_mortal(SVt_PVAV); av_extend((AV *)res, nret); while (nret--) + /* Naughtily, we don't increment the ref counts + * of the items we push onto the temporary array. + * So we rely on the caller knowing not to decrement them, + * and to empty the array before there's any chance of + * it being freed. (Probably should either turn off + * AvREAL or actually increment.) + */ av_store((AV *)res, nret, POPs); break; } diff --git a/pp.c b/pp.c index 74d2e0fa944e..44bca5b117e5 100644 --- a/pp.c +++ b/pp.c @@ -186,9 +186,10 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, return sv; } -PP_wrapped(pp_rv2gv, 1, 0) + +PP(pp_rv2gv) { - dSP; dTOPss; + SV *sv = *PL_stack_sp; sv = S_rv2gv(aTHX_ sv, PL_op->op_private & OPpDEREF, @@ -198,10 +199,11 @@ PP_wrapped(pp_rv2gv, 1, 0) ); if (PL_op->op_private & OPpLVAL_INTRO) save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); - SETs(sv); - RETURN; + rpp_replace_1_1(sv); + return NORMAL; } + /* Helper function for pp_rv2sv and pp_rv2av/hv. * * Return a GV based on the value of sv, using symbolic references etc. @@ -3789,9 +3791,11 @@ PP_wrapped(pp_vec, 3, 0) /* also used for: pp_rindex() */ -PP_wrapped(pp_index, MAXARG, 0) +PP(pp_index) { - dSP; dTARGET; + SV *targ = (PL_op->op_flags & OPf_STACKED) + ? PL_stack_sp[-1] + : PAD_SV(PL_op->op_targ); SV *big; SV *little; SV *temp = NULL; @@ -3804,12 +3808,24 @@ PP_wrapped(pp_index, MAXARG, 0) bool big_utf8; bool little_utf8; const bool is_index = PL_op->op_type == OP_INDEX; - const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0)); - if (threeargs) - offset = POPi; - little = POPs; - big = POPs; + assert(MAXARG == 2 || MAXARG == 3); + + bool threeargs = (MAXARG == 3); + if (MAXARG == 3 && !PL_stack_sp[0]) { + /* pp_coreargs pushes a NULL in order to flag that &CORE::index() + * was called with two args */ + PL_stack_sp--; + threeargs = FALSE; + } + + if (threeargs) { + offset = SvIV(*PL_stack_sp); + rpp_popfree_1(); + } + + little = PL_stack_sp[0]; + big = PL_stack_sp[-1]; big_p = SvPV_const(big, biglen); little_p = SvPV_const(little, llen); @@ -3896,20 +3912,20 @@ PP_wrapped(pp_index, MAXARG, 0) if (PL_op->op_private & OPpTRUEBOOL) { SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG)) ? &PL_sv_yes : &PL_sv_no; - if (PL_op->op_private & OPpTARGET_MY) { + if (PL_op->op_private & OPpTARGET_MY) /* $lex = (index() == -1) */ - sv_setsv_mg(TARG, result); - PUSHs(TARG); - } - else { - PUSHs(result); - } + sv_setsv_mg(targ, result); + else + targ = result; } else - PUSHi(retval); - RETURN; + TARGi(retval, 1); + + rpp_replace_2_1(targ); + return NORMAL; } + PP_wrapped(pp_sprintf, 0, 1) { dSP; dMARK; dORIGMARK; dTARGET; diff --git a/pp.h b/pp.h index 8ac7e5aa0a43..866c01e1e3e2 100644 --- a/pp.h +++ b/pp.h @@ -681,51 +681,6 @@ Does not use C. See also C>, C> and C>. /* No longer used in core. Use AMG_CALLunary instead */ #define AMG_CALLun(sv,meth) AMG_CALLunary(sv, CAT2(meth,_amg)) -#define tryAMAGICunTARGETlist(meth, jump) \ - STMT_START { \ - dSP; \ - SV *tmpsv; \ - SV *arg= *sp; \ - U8 gimme = GIMME_V; \ - if (UNLIKELY(SvAMAGIC(arg) && \ - (tmpsv = amagic_call(arg, &PL_sv_undef, meth, \ - AMGf_want_list | AMGf_noright \ - |AMGf_unary)))) \ - { \ - SPAGAIN; \ - if (gimme == G_VOID) { \ - NOOP; \ - } \ - else if (gimme == G_LIST) { \ - SSize_t i; \ - SSize_t len; \ - assert(SvTYPE(tmpsv) == SVt_PVAV); \ - len = av_count((AV *)tmpsv); \ - (void)POPs; /* get rid of the arg */ \ - EXTEND(sp, len); \ - for (i = 0; i < len; ++i) \ - PUSHs(av_shift((AV *)tmpsv)); \ - } \ - else { /* AMGf_want_scalar */ \ - dATARGET; /* just use the arg's location */ \ - sv_setsv(TARG, tmpsv); \ - if (PL_op->op_flags & OPf_STACKED) \ - sp--; \ - SETTARG; \ - } \ - PUTBACK; \ - if (jump) { \ - OP *jump_o = NORMAL->op_next; \ - while (jump_o->op_type == OP_NULL) \ - jump_o = jump_o->op_next; \ - assert(jump_o->op_type == OP_ENTERSUB); \ - (void)POPMARK; \ - return jump_o->op_next; \ - } \ - return NORMAL; \ - } \ - } STMT_END - /* This is no longer used anywhere in the core. You might wish to consider calling amagic_deref_call() directly, as it has a cleaner interface. */ #define tryAMAGICunDEREF(meth) \ diff --git a/pp_hot.c b/pp_hot.c index 0061f83e5282..be0741bba285 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1490,29 +1490,123 @@ PP(pp_padsv) } } -PP_wrapped(pp_readline, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0) + +/* Implement readline(), and also and <> in the cases where X is + * seen by the parser as file-handle-ish rather than glob-ish. + * + * It expects at least one arg: the typeglob or scalar filehandle to read + * from. An empty <> isn't handled specially by this op; instead the parser + * will have planted a preceding gv(*ARGV) op. + * + * Scalar assignment is optimised away by making the assignment target be + * passed as a second argument, with OPf_STACKED set. For example, + * + * $x[$i] = readline($fh); + * + * is implemented as if written as + * + * readline($x[$i], $fh); + * + * (that is, if the perl-level readline function took two args, which it + * doesn't). The 'while (<>) {...}' construct is handled specially by the + * parser, but not specially by this op. The parser treats the condition + * as + * + * defined($_ = <>) + * + * which is then optimised into the equivalent of + * + * defined(readline($_, *ARGV)) + * + * When called as a real function, e.g. (\&CORE::readline)->(*STDIN), + * pp_coreargs() will have pushed a NULL if no argument was supplied. + * + * The parser decides whether '' in the perl src code causes an + * OP_GLOB or an OPREADLINE op to be planted. + */ + +PP(pp_readline) { - dSP; + SV *arg = *PL_stack_sp; + /* pp_coreargs pushes a NULL to indicate no args passed to * CORE::readline() */ - if (TOPs) { - SvGETMAGIC(TOPs); - tryAMAGICunTARGETlist(iter_amg, 0); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + if (arg) { + SvGETMAGIC(arg); + + /* unrolled tryAMAGICunTARGETlist(iter_amg, 0) */ + SV *tmpsv; + U8 gimme = GIMME_V; + if (UNLIKELY(SvAMAGIC(arg) && + (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg, + AMGf_want_list | AMGf_noright + |AMGf_unary)))) + { + if (gimme == G_VOID) { + NOOP; + } + else if (gimme == G_LIST) { + SSize_t i; + SSize_t len; + assert(SvTYPE(tmpsv) == SVt_PVAV); + len = av_count((AV *)tmpsv); + assert(*PL_stack_sp == arg); + rpp_popfree_1(); /* pop the original filehhandle arg */ + /* no assignment target to pop */ + assert(!(PL_op->op_flags & OPf_STACKED)); + rpp_extend(len); + for (i = 0; i < len; ++i) + /* amagic_call() naughtily doesn't increment the ref counts + * of the items it pushes onto the temporary array. So we + * don't need to decrement them when shifting off. */ + rpp_push_1(av_shift((AV *)tmpsv)); + } + else { /* AMGf_want_scalar */ + /* OPf_STACKED: assignment optimised away and target + * on stack */ + SV *targ = (PL_op->op_flags & OPf_STACKED) + ? PL_stack_sp[-1] + : PAD_SV(PL_op->op_targ); + sv_setsv(targ, tmpsv); + SvSETMAGIC(targ); + if (PL_op->op_flags & OPf_STACKED) { + rpp_popfree_1(); + assert(*PL_stack_sp == targ); + } + else + rpp_replace_1_1(targ); + } + return NORMAL; + } + /* end of unrolled tryAMAGICunTARGETlist */ + + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp); +#ifdef PERL_RC_STACK + /* PL_last_in_gv appears to be non-refcounted, so won't keep + * GV alive */ + if (SvREFCNT(PL_last_in_gv) < 2) + sv_2mortal((SV*)PL_last_in_gv); +#endif } - else PL_last_in_gv = PL_argvgv, PL_stack_sp--; + else + PL_last_in_gv = PL_argvgv; + + rpp_popfree_1(); + + /* is it *FOO, $fh, or 'FOO' ? */ 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)); else { - dSP; - XPUSHs(MUTABLE_SV(PL_last_in_gv)); - PUTBACK; + rpp_xpush_1(MUTABLE_SV(PL_last_in_gv)); Perl_pp_rv2gv(aTHX); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); - assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv)); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp); + rpp_popfree_1(); + assert( (SV*)PL_last_in_gv == &PL_sv_undef + || isGV_with_GP(PL_last_in_gv)); } } + return do_readline(); } @@ -3843,34 +3937,122 @@ PP(pp_match) } +/* Perl_do_readline(): implement <$fh>, readline($fh) and glob('*.h') + * + * This function is tail-called by pp_readline(), pp_rcatline() and + * pp_glob(), and it may check PL_op's op_type and op_flags as + * appropriate. + * + * For file reading: + * It reads the line(s) from PL_last_in_gv. + * It returns a list of lines, or in scalar context, reads one line into + * targ (or if OPf_STACKED, into the top SV on the stack), and + * returns that. (If OP_RCATLINE, concats rather than sets). + * + * So it normally expects zero args, or one arg when the OPf_STACKED + * optimisation is present. + * + * For file globbing: + * Note that we don't normally reach here: we only get here if perl is + * built with PERL_EXTERNAL_GLOB, which is normally only when + * building miniperl. + * + * Expects one arg, which is the pattern string (e.g. '*.h'). + * The caller sets PL_last_in_gv to a plain GV that just has a new + * IO::File PVIO attached. + * + * Handles tied IO magic, but not overloading - that's the caller's + * responsibility. + * + * Handles the *ARGV filehandle specially, to do all the <> wizardry. + * + * In summary: on entry, the stack has zero or one items pushed, and + * looks like: + * + * - when OP_READLINE without OPf_STACKED + * target when OP_READLINE with OPf_STACKED, or when OP_RCATLINE + * '*.h' when OP_GLOB + */ + OP * Perl_do_readline(pTHX) { - dSP; dTARGETSTACKED; + + const I32 type = PL_op->op_type; + + /* only readline/rcatline can have the STACKED optimisation, + * and rcatline *always* has it */ + if (PL_op->op_flags & OPf_STACKED) { + assert(type != OP_GLOB); + assert(GIMME_V == G_SCALAR); + } + if (type == OP_RCATLINE) + assert(PL_op->op_flags & OPf_STACKED); + + const U8 gimme = GIMME_V; + SV *targ = (gimme == G_SCALAR) + ? (PL_op->op_flags & OPf_STACKED) + ? *PL_stack_sp + : PAD_SV(PL_op->op_targ) + : NULL; SV *sv; STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; IO * const io = GvIO(PL_last_in_gv); - const I32 type = PL_op->op_type; - const U8 gimme = GIMME_V; + + /* process tied file handle if present */ if (io) { const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0); + /* not possible for the faked-up IO passed by an OP_GLOB to be + * tied */ + assert(type != OP_GLOB); + /* OPf_STACKED only applies when in scalar context */ + assert(!(gimme != G_SCALAR && (PL_op->op_flags & OPf_STACKED))); + + /* tied_method() frees everything currently above the passed + * mark, and returns any values at mark[1] onwards */ + Perl_tied_method(aTHX_ SV_CONST(READLINE), + /* mark => */ PL_stack_sp, + MUTABLE_SV(io), mg, gimme, 0); + if (gimme == G_SCALAR) { - SPAGAIN; - SvSetSV_nosteal(TARG, TOPs); - SETTARG; + SvSetSV_nosteal(targ, *PL_stack_sp); + SvSETMAGIC(targ); + if (PL_op->op_flags & OPf_STACKED) { + /* free the tied method call's return value */ + rpp_popfree_1(); + assert(*PL_stack_sp == targ); + } + else + rpp_replace_1_1(targ); } + else + /* no targ to pop off the stack - any returned values + * are in the right place in the stack */ + assert(!(PL_op->op_flags & OPf_STACKED)); + return NORMAL; } } + fp = NULL; + + /* handle possible *ARGV, and check for read on write-only FH */ + if (io) { fp = IoIFP(io); - if (!fp) { + if (fp) { + /* not possible for the faked-up IO passed by an OP_GLOB to + * have a file handle */ + assert(type != OP_GLOB); + + if (IoTYPE(io) == IoTYPE_WRONLY) + report_wrongway_fh(PL_last_in_gv, '>'); + } + else { if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { IoLINES(io) = 0; @@ -3889,15 +4071,15 @@ Perl_do_readline(pTHX) (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } } - else if (type == OP_GLOB) - fp = Perl_start_glob(aTHX_ POPs, io); - } - else if (type == OP_GLOB) - SP--; - else if (IoTYPE(io) == IoTYPE_WRONLY) { - report_wrongway_fh(PL_last_in_gv, '>'); + else if (type == OP_GLOB) { + fp = Perl_start_glob(aTHX_ *PL_stack_sp, io); + rpp_popfree_1(); + } } } + + /* handle bad file handle */ + if (!fp) { if ((!io || !(IoFLAGS(io) & IOf_START)) && ckWARN(WARN_CLOSED) @@ -3905,20 +4087,26 @@ Perl_do_readline(pTHX) { report_evil_fh(PL_last_in_gv); } + if (gimme == G_SCALAR) { - /* undef TARG, and push that undefined value */ - if (type != OP_RCATLINE) { - sv_set_undef(TARG); - } - PUSHTARG; + /* undef targ, and return that undefined value */ + if (type != OP_RCATLINE) + sv_set_undef(targ); + if (!(PL_op->op_flags & OPf_STACKED)) + rpp_push_1(targ); } - RETURN; + return NORMAL; } + have_fp: + + /* prepare targ to have a string assigned to it */ + if (gimme == G_SCALAR) { - sv = TARG; + sv = targ; if (type == OP_RCATLINE && SvGMAGICAL(sv)) mg_get(sv); + if (SvROK(sv)) { if (type == OP_RCATLINE) SvPV_force_nomg_nolen(sv); @@ -3928,6 +4116,7 @@ Perl_do_readline(pTHX) else if (isGV_with_GP(sv)) { SvPV_force_nomg_nolen(sv); } + SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { @@ -3936,6 +4125,7 @@ Perl_do_readline(pTHX) */ Sv_Grow(sv, 80); } + offset = 0; if (type == OP_RCATLINE && SvOK(sv)) { if (!SvPOK(sv)) { @@ -3945,6 +4135,7 @@ Perl_do_readline(pTHX) } } else { + /* XXX on RC builds, push on stack rather than mortalize ? */ sv = sv_2mortal(newSV(80)); offset = 0; } @@ -3961,8 +4152,9 @@ Perl_do_readline(pTHX) (gimme != G_SCALAR || SvCUR(sv) \ || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) + /* create one or more lines, or (if OP_GLOB), pathnames */ + for (;;) { - PUTBACK; if (!sv_gets(sv, fp, offset) && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv) @@ -3988,27 +4180,44 @@ Perl_do_readline(pTHX) (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } + if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { - SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); + SV_CHECK_THINKFIRST_COW_DROP(targ); + SvOK_off(targ); } - SPAGAIN; - PUSHTARG; + /* targ not already there? */ + if (!(PL_op->op_flags & OPf_STACKED)) + rpp_push_1(targ); } + else if (PL_op->op_flags & OPf_STACKED) + rpp_popfree_1(); + MAYBE_TAINT_LINE(io, sv); - RETURN; + return NORMAL; } + MAYBE_TAINT_LINE(io, sv); IoLINES(io)++; IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); - SPAGAIN; - XPUSHs(sv); + rpp_extend(1); + if (PL_op->op_flags & OPf_STACKED) { + /* push sv while keeping targ above it, so targ doesn't get + * freed */ + assert(*PL_stack_sp == targ); + PL_stack_sp[1] = targ; + *PL_stack_sp++ = NULL; + rpp_replace_at(PL_stack_sp - 1, sv); + } + else + rpp_push_1(sv); + if (type == OP_GLOB) { const char *t1; Stat_t statbuf; + /* chomp(sv) */ if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { char * const tmps = SvEND(sv) - 1; if (*tmps == *SvPVX_const(PL_rs)) { @@ -4016,18 +4225,26 @@ Perl_do_readline(pTHX) SvCUR_set(sv, SvCUR(sv) - 1); } } - for (t1 = SvPVX_const(sv); *t1; t1++) + + /* find longest substring of sv up to first metachar */ + for (t1 = SvPVX_const(sv); *t1; t1++) { #ifdef __VMS if (memCHRs("*%?", *t1)) #else if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1)) #endif break; + } + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { - (void)POPs; /* Unmatched wildcard? Chuck it... */ + /* Unmatched wildcard? Chuck it... */ + /* no need to worry about targ still on top of stack */ + assert(!(PL_op->op_flags & OPf_STACKED)); + rpp_popfree_1(); continue; } } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ + /* check line if valid Unicode */ if (ckWARN(WARN_UTF8)) { const U8 * const s = (const U8*)SvPVX_const(sv) + offset; const STRLEN len = SvCUR(sv) - offset; @@ -4040,23 +4257,32 @@ Perl_do_readline(pTHX) f < (U8*)SvEND(sv) ? *f : 0); } } + if (gimme == G_LIST) { if (SvLEN(sv) - SvCUR(sv) > 20) { SvPV_shrink_to_cur(sv); } + /* XXX on RC builds, push on stack rather than mortalize ? */ sv = sv_2mortal(newSV(80)); continue; } - else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { + + if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { /* try to reclaim a bit of scalar space (only on 1st alloc) */ const STRLEN new_len = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ SvPV_renew(sv, new_len); } - RETURN; - } + + + if (PL_op->op_flags & OPf_STACKED) + rpp_popfree_1(); /* finally remove targ */ + /* return sv, which was recently pushed onto the stack */ + return NORMAL; + } /* for (;;) */ } + PP(pp_helem) { HE* he; diff --git a/pp_sys.c b/pp_sys.c index 636280ca5a2f..1deb3813fe68 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -339,29 +339,149 @@ PP_wrapped(pp_backtick, 1, 0) RETURN; } -PP_wrapped(pp_glob, 1 + !(PL_op->op_flags & OPf_SPECIAL), 0) + +/* Implement glob('*.h'), and also in the cases where the X is seen by + * the parser as glob-ish rather than file-handle-ish. + * + * The first arg is the wildcard. + * + * The second arg is a gv which (for some reason) is just an empty + * placeholder to temporarily assign to PL_last_in_gv. It's a GV unique to + * this op with only a plain PVIO attached, which is in stash IO::File. + * Presumably this is used because we tail-call do_readline(), which + * expects PL_last_in_gv to be set. + * + * With OPf_SPECIAL, the second arg isn't present, but a stack MARK is, + * and the glob is done by following on in op_next to a perl-level + * function call. + * + * Normally, the actual glob work is done within a tail-call to + * do_readline(). + * + * The parser decides whether '' in the perl src code causes an + * OP_GLOB or an OPREADLINE op to be planted. + */ + +PP(pp_glob) { OP *result; - dSP; - GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; + GV *gv; + if (UNLIKELY(PL_op->op_flags & OPf_SPECIAL)) { + /* no GV on stack */ + gv = NULL; + } + else { + gv = (GV*)*PL_stack_sp; + /* Normally things can't just be popped off the stack without risk + * of premature freeing, but in this case the GV is always + * referenced by a preceding OP_GV. */ + assert(!rpp_is_lone((SV*)gv)); + rpp_popfree_1(); + } - PUTBACK; /* make a copy of the pattern if it is gmagical, to ensure that magic * is called once and only once */ - if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs)); + SV *arg = *PL_stack_sp; + if (SvGMAGICAL(arg)) + rpp_replace_at_norc(PL_stack_sp, ((arg = newSVsv(arg)) )); + + /* unrolled + tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); */ + SV *tmpsv; + U8 gimme = GIMME_V; + if (UNLIKELY(SvAMAGIC(arg) && + (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg, + AMGf_want_list | AMGf_noright + |AMGf_unary)))) + { + if (gimme == G_VOID) { + NOOP; + } + else if (gimme == G_LIST) { + SSize_t i; + SSize_t len; + assert(SvTYPE(tmpsv) == SVt_PVAV); + len = av_count((AV *)tmpsv); + assert(*PL_stack_sp == arg); + rpp_popfree_1(); /* pop the original wildcard arg */ + rpp_extend(len); + for (i = 0; i < len; ++i) + /* amagic_call() naughtily doesn't increment the ref counts + * of the items it pushes onto the temporary array. So we + * don't need to decrement them when shifting off. */ + rpp_push_1(av_shift((AV *)tmpsv)); + } + else { /* AMGf_want_scalar */ + SV *targ = PAD_SV(PL_op->op_targ); + sv_setsv(targ, tmpsv); + SvSETMAGIC(targ); + /* replace the original wildcard arg with result */ + assert(*PL_stack_sp == arg); + rpp_replace_1_1(targ); + } + + if (PL_op->op_flags & OPf_SPECIAL) { + /* skip the following gv(CORE::GLOBAL::glob), entersub ops */ + OP *jump_o = PL_op->op_next->op_next; + while (jump_o->op_type == OP_NULL) + jump_o = jump_o->op_next; + assert(jump_o->op_type == OP_ENTERSUB); + (void)POPMARK; + return jump_o->op_next; + } + + return NORMAL; + } + /* end of unrolled tryAMAGICunTARGETlist */ - tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); if (PL_op->op_flags & OPf_SPECIAL) { - /* call Perl-level glob function instead. Stack args are: - * MARK, wildcard + /* call Perl-level glob function instead. E.g. + * use File::DosGlob 'glob'; @files = glob('*.h'); + * Stack args are: [MARK] wildcard * and following OPs should be: gv(CORE::GLOBAL::glob), entersub * */ return NORMAL; } + if (PL_globhook) { +#ifdef PERL_RC_STACK + /* Likely calling csh_glob_iter() in File::Glob, which doesn't + * understand PERL_RC_STACK yet. If it was an XS function we could + * use rpp_invoke_xs(); but as it's just a "raw" static function, + * wrap it ourselves. There's always one arg, and it will return + * one value in void/scalar context (possibly PL_sv_undef), or 0+ + * values in list cxt. */ + + assert(AvREAL(PL_curstack)); + assert(!PL_curstackinfo->si_stack_nonrc_base); + + rpp_extend(1); + PL_stack_sp[1] = PL_stack_sp[0]; + PL_stack_sp++; + PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base; + + PL_globhook(aTHX); + + I32 nret = (I32)(PL_stack_sp - PL_stack_base) + - PL_curstackinfo->si_stack_nonrc_base + 1; + assert(nret >= 0); + + /* bump any returned values */ + for (I32 i = 0; i< nret; i++) + SvREFCNT_inc(PL_stack_sp[-i]); + PL_curstackinfo->si_stack_nonrc_base = 0; + + /* free the original arg and shift the returned values down */ + SV *arg = PL_stack_sp[-nret]; + if (nret) + Move(PL_stack_sp - nret + 1, PL_stack_sp - nret, nret, SV*); + PL_stack_sp--; + SvREFCNT_dec_NN(arg); +#else PL_globhook(aTHX); +#endif return NORMAL; } @@ -398,12 +518,18 @@ PP_wrapped(pp_glob, 1 + !(PL_op->op_flags & OPf_SPECIAL), 0) return result; } -PP_wrapped(pp_rcatline, 1, 0) + +/* $x .= + * Where $x is on the stack and FOO is the GV attached to the op. + */ + +PP(pp_rcatline) { PL_last_in_gv = cGVOP_gv; return do_readline(); } + PP_wrapped(pp_warn, 0, 1) { dSP; dMARK;