void Perl_av_extend(pTHX_ AV *av, I32 key) { MAGIC * const mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied); if (mg) { dSP; ENTER; SAVETMPS; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj((SV*)av, mg)); PUSHs(sv_2mortal(newSViv(key+1))); PUTBACK; call_method("EXTEND", G_SCALAR|G_DISCARD); POPSTACK; FREETMPS; LEAVE; return; } if (key > AvMAX(av)) { SV** ary; I32 tmp; I32 newmax; if (AvALLOC(av) != AvARRAY(av)) { ary = AvALLOC(av) + AvFILLp(av) + 1; tmp = AvARRAY(av) - AvALLOC(av); Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*); AvMAX(av) += tmp; SvPV_set(av, (char*)AvALLOC(av)); if (AvREAL(av)) { while (tmp) ary[--tmp] = &PL_sv_undef; } if (key > AvMAX(av) - 10) { newmax = key + AvMAX(av); goto resize; } }
/* =for apidoc mro_get_linear_isa_dfs Returns the Depth-First Search linearization of @ISA the given stash. The return value is a read-only AV*. C<level> should be 0 (it is used internally in this function's recursion). You are responsible for C<SvREFCNT_inc()> on the return value if you plan to store it anywhere semi-permanently (otherwise it might be deleted out from under you the next time the cache is invalidated). =cut */ static AV* S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) { AV* retval; GV** gvp; GV* gv; AV* av; const HEK* stashhek; struct mro_meta* meta; SV *our_name; HV *stored; PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS; assert(HvAUX(stash)); stashhek = HvNAME_HEK(stash); if (!stashhek) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HEK_KEY(stashhek)); meta = HvMROMETA(stash); /* return cache if valid */ if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) { return retval; } /* not in cache, make a new one */ retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); /* We use this later in this function, but don't need a reference to it beyond the end of this function, so reference count is fine. */ our_name = newSVhek(stashhek); av_push(retval, our_name); /* add ourselves at the top */ /* fetch our @ISA */ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; /* "stored" is used to keep track of all of the classnames we have added to the MRO so far, so we can do a quick exists check and avoid adding duplicate classnames to the MRO as we go. It's then retained to be re-used as a fast lookup for ->isa(), by adding our own name and "UNIVERSAL" to it. */ stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); if(av && AvFILLp(av) >= 0) { SV **svp = AvARRAY(av); I32 items = AvFILLp(av) + 1; /* foreach(@ISA) */ while (items--) { SV* const sv = *svp++; HV* const basestash = gv_stashsv(sv, 0); SV *const *subrv_p; I32 subrv_items; if (!basestash) { /* if no stash exists for this @ISA member, simply add it to the MRO and move on */ subrv_p = &sv; subrv_items = 1; } else { /* otherwise, recurse into ourselves for the MRO of this @ISA member, and append their MRO to ours. The recursive call could throw an exception, which has memory management implications here, hence the use of the mortal. */ const AV *const subrv = mro_get_linear_isa_dfs(basestash, level + 1); subrv_p = AvARRAY(subrv); subrv_items = AvFILLp(subrv) + 1; } while(subrv_items--) { SV *const subsv = *subrv_p++; /* LVALUE fetch will create a new undefined SV if necessary */ HE *const he = hv_fetch_ent(stored, subsv, 1, 0); assert(he); if(HeVAL(he) != &PL_sv_undef) { /* It was newly created. Steal it for our new SV, and replace it in the hash with the "real" thing. */ SV *const val = HeVAL(he); HEK *const key = HeKEY_hek(he); HeVAL(he) = &PL_sv_undef; /* Save copying by making a shared hash key scalar. We inline this here rather than calling Perl_newSVpvn_share because we already have the scalar, and we already have the hash key. */ assert(SvTYPE(val) == SVt_NULL); sv_upgrade(val, SVt_PV); SvPV_set(val, HEK_KEY(share_hek_hek(key))); SvCUR_set(val, HEK_LEN(key)); SvREADONLY_on(val); SvFAKE_on(val); SvPOK_on(val); if (HEK_UTF8(key)) SvUTF8_on(val); av_push(retval, val); } } } } (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0); (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0); SvREFCNT_inc_simple_void_NN(stored); SvTEMP_off(stored); SvREADONLY_on(stored); meta->isa = stored; /* now that we're past the exception dangers, grab our own reference to the AV we're about to use for the result. The reference owned by the mortals' stack will be released soon, so everything will balance. */ SvREFCNT_inc_simple_void_NN(retval); SvTEMP_off(retval); /* we don't want anyone modifying the cache entry but us, and we do so by replacing it completely */ SvREADONLY_on(retval); return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg, MUTABLE_SV(retval))); }
IV PerlIOEncode_flush(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); IV code = 0; if (e->bufsv) { dSP; SV *str; char *s; STRLEN len; SSize_t count = 0; if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) { if (e->inEncodeCall) return 0; /* Write case - encode the buffer and write() to layer below */ PUSHSTACKi(PERLSI_MAGIC); SPAGAIN; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(e->enc); SvCUR_set(e->bufsv, e->base.ptr - e->base.buf); SvUTF8_on(e->bufsv); XPUSHs(e->bufsv); XPUSHs(e->chk); PUTBACK; e->inEncodeCall = 1; if (call_method("encode", G_SCALAR) != 1) { e->inEncodeCall = 0; Perl_die(aTHX_ "panic: encode did not return a value"); } e->inEncodeCall = 0; SPAGAIN; str = POPs; PUTBACK; s = SvPV(str, len); count = PerlIO_write(PerlIONext(f),s,len); if ((STRLEN)count != len) { code = -1; } FREETMPS; LEAVE; POPSTACK; if (PerlIO_flush(PerlIONext(f)) != 0) { code = -1; } if (SvCUR(e->bufsv)) { /* Did not all translate */ e->base.ptr = e->base.buf+SvCUR(e->bufsv); return code; } } else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { /* read case */ /* if we have any untranslated stuff then unread that first */ /* FIXME - unread is fragile is there a better way ? */ if (e->dataSV && SvCUR(e->dataSV)) { s = SvPV(e->dataSV, len); count = PerlIO_unread(PerlIONext(f),s,len); if ((STRLEN)count != len) { code = -1; } SvCUR_set(e->dataSV,0); } /* See if there is anything left in the buffer */ if (e->base.ptr < e->base.end) { if (e->inEncodeCall) return 0; /* Bother - have unread data. re-encode and unread() to layer below */ PUSHSTACKi(PERLSI_MAGIC); SPAGAIN; ENTER; SAVETMPS; str = sv_newmortal(); sv_upgrade(str, SVt_PV); SvPV_set(str, (char*)e->base.ptr); SvLEN_set(str, 0); SvCUR_set(str, e->base.end - e->base.ptr); SvPOK_only(str); SvUTF8_on(str); PUSHMARK(sp); XPUSHs(e->enc); XPUSHs(str); XPUSHs(e->chk); PUTBACK; e->inEncodeCall = 1; if (call_method("encode", G_SCALAR) != 1) { e->inEncodeCall = 0; Perl_die(aTHX_ "panic: encode did not return a value"); } e->inEncodeCall = 0; SPAGAIN; str = POPs; PUTBACK; s = SvPV(str, len); count = PerlIO_unread(PerlIONext(f),s,len); if ((STRLEN)count != len) { code = -1; } FREETMPS; LEAVE; POPSTACK; } } e->base.ptr = e->base.end = e->base.buf; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); } return code; }
IV PerlIOEncode_fill(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); dSP; IV code = 0; PerlIO *n; SSize_t avail; if (PerlIO_flush(f) != 0) return -1; n = PerlIONext(f); if (!PerlIO_fast_gets(n)) { /* Things get too messy if we don't have a buffer layer push a :perlio to do the job */ char mode[8]; n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv); if (!n) { Perl_die(aTHX_ "panic: cannot push :perlio for %p",f); } } PUSHSTACKi(PERLSI_MAGIC); SPAGAIN; ENTER; SAVETMPS; retry: avail = PerlIO_get_cnt(n); if (avail <= 0) { avail = PerlIO_fill(n); if (avail == 0) { avail = PerlIO_get_cnt(n); } else { if (!PerlIO_error(n) && PerlIO_eof(n)) avail = 0; } } if (avail > 0 || (e->flags & NEEDS_LINES)) { STDCHAR *ptr = PerlIO_get_ptr(n); SSize_t use = (avail >= 0) ? avail : 0; SV *uni; char *s = NULL; STRLEN len = 0; e->base.ptr = e->base.end = (STDCHAR *) NULL; (void) PerlIOEncode_get_base(aTHX_ f); if (!e->dataSV) e->dataSV = newSV(0); if (SvTYPE(e->dataSV) < SVt_PV) { sv_upgrade(e->dataSV,SVt_PV); } if (e->flags & NEEDS_LINES) { /* Encoding needs whole lines (e.g. iso-2022-*) search back from end of available data for and line marker */ STDCHAR *nl = ptr+use-1; while (nl >= ptr) { if (*nl == '\n') { break; } nl--; } if (nl >= ptr && *nl == '\n') { /* found a line - take up to and including that */ use = (nl+1)-ptr; } else if (avail > 0) { /* No line, but not EOF - append avail to the pending data */ sv_catpvn(e->dataSV, (char*)ptr, use); PerlIO_set_ptrcnt(n, ptr+use, 0); goto retry; } else if (!SvCUR(e->dataSV)) { goto end_of_file; } } if (SvCUR(e->dataSV)) { /* something left over from last time - create a normal SV with new data appended */ if (use + SvCUR(e->dataSV) > e->base.bufsiz) { if (e->flags & NEEDS_LINES) { /* Have to grow buffer */ e->base.bufsiz = use + SvCUR(e->dataSV); PerlIOEncode_get_base(aTHX_ f); } else { use = e->base.bufsiz - SvCUR(e->dataSV); } } sv_catpvn(e->dataSV,(char*)ptr,use); } else { /* Create a "dummy" SV to represent the available data from layer below */ if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) { Safefree(SvPVX_mutable(e->dataSV)); } if (use > (SSize_t)e->base.bufsiz) { if (e->flags & NEEDS_LINES) { /* Have to grow buffer */ e->base.bufsiz = use; PerlIOEncode_get_base(aTHX_ f); } else { use = e->base.bufsiz; } } SvPV_set(e->dataSV, (char *) ptr); SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */ SvCUR_set(e->dataSV,use); SvPOK_only(e->dataSV); } SvUTF8_off(e->dataSV); PUSHMARK(sp); XPUSHs(e->enc); XPUSHs(e->dataSV); XPUSHs(e->chk); PUTBACK; if (call_method("decode", G_SCALAR) != 1) { Perl_die(aTHX_ "panic: decode did not return a value"); } SPAGAIN; uni = POPs; PUTBACK; /* Now get translated string (forced to UTF-8) and use as buffer */ if (SvPOK(uni)) { s = SvPVutf8(uni, len); #ifdef PARANOID_ENCODE_CHECKS if (len && !is_utf8_string((U8*)s,len)) { Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s); } #endif } if (len > 0) { /* Got _something */ /* if decode gave us back dataSV then data may vanish when we do ptrcnt adjust - so take our copy now. (The copy is a pain - need a put-it-here option for decode.) */ sv_setpvn(e->bufsv,s,len); e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv); e->base.end = e->base.ptr + SvCUR(e->bufsv); PerlIOBase(f)->flags |= PERLIO_F_RDBUF; SvUTF8_on(e->bufsv); /* Adjust ptr/cnt not taking anything which did not translate - not clear this is a win */ /* compute amount we took */ use -= SvCUR(e->dataSV); PerlIO_set_ptrcnt(n, ptr+use, (avail-use)); /* and as we did not take it it isn't pending */ SvCUR_set(e->dataSV,0); } else { /* Got nothing - assume partial character so we need some more */ /* Make sure e->dataSV is a normal SV before re-filling as buffer alias will change under us */ s = SvPV(e->dataSV,len); sv_setpvn(e->dataSV,s,len); PerlIO_set_ptrcnt(n, ptr+use, (avail-use)); goto retry; } } else { end_of_file: code = -1; if (avail == 0) PerlIOBase(f)->flags |= PERLIO_F_EOF; else PerlIOBase(f)->flags |= PERLIO_F_ERROR; } FREETMPS; LEAVE; POPSTACK; return code; }