void dualize(SV* arg, const char* string) {
svtype sv_type;
sv_type = SvTYPE(arg);
switch(sv_type) {
case SVt_IV:
SvUPGRADE(arg, SVt_PVIV);
sv_setpv(arg, string);
SvIOK_on(arg);
break;
case SVt_NV:
SvUPGRADE(arg, SVt_PVNV);
sv_setpv(arg, string);
SvNOK_on(arg);
break;
// how do we do this for blessed refs?
// this doesn't work
case SVt_PVMG:
sv_setpv(arg, string);
break;
default:
DEBUGME(2, "Got svtype of %d", sv_type);
}
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
s->var = SvREFCNT_inc(SvRV(arg));
if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
(void)SvPV_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR(s->var) = 0;
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
static void
S_lazy_init_host_obj(kino_Obj *self)
{
SV *inner_obj = newSV(0);
SvOBJECT_on(inner_obj);
PL_sv_objcount++;
SvUPGRADE(inner_obj, SVt_PVMG);
sv_setiv(inner_obj, PTR2IV(self));
// Connect class association.
kino_CharBuf *class_name = Kino_VTable_Get_Name(self->vtable);
HV *stash = gv_stashpvn((char*)Kino_CB_Get_Ptr8(class_name),
Kino_CB_Get_Size(class_name), TRUE);
SvSTASH_set(inner_obj, (HV*)SvREFCNT_inc(stash));
/* Up till now we've been keeping track of the refcount in
* self->ref.count. We're replacing ref.count with ref.host_obj, which
* will assume responsibility for maintaining the refcount. ref.host_obj
* starts off with a refcount of 1, so we need to transfer any refcounts
* in excess of that. */
size_t old_refcount = self->ref.count;
self->ref.host_obj = inner_obj;
while (old_refcount > 1) {
SvREFCNT_inc_simple_void_NN(inner_obj);
old_refcount--;
}
}
GLvoid * EL(SV * sv, int needlen)
{
STRLEN skip = 0;
SV * svref;
if (SvREADONLY(sv))
croak("Readonly value for buffer");
if(SvROK(sv)) {
svref = SvRV(sv);
sv = svref;
}
else
{
#ifdef USE_STRICT_UNGLOB
if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
sv_unglob(sv);
#endif
SvUPGRADE(sv, SVt_PV);
SvGROW(sv, (unsigned int)(needlen + 1));
SvPOK_on(sv);
SvCUR_set(sv, needlen);
*SvEND(sv) = '\0'; /* Why is this here? -chm */
}
return SvPV_force(sv, skip);
}
void
Perl_set_version(pTHX_ const char *name, STRLEN nlen, const char *strval, STRLEN plen, NV nvval)
{
SV* ver = GvSV(gv_add_by_type(gv_fetchpvn(name, nlen, GV_ADD, SVt_PVNV),
SVt_PVNV));
PERL_ARGS_ASSERT_SET_VERSION;
SvREADONLY_off(ver);
SvUPGRADE(ver, SVt_PVNV);
SvPVX(ver) = SvGROW(ver, plen+1);
Move(strval, SvPVX(ver), plen, char);
SvCUR_set(ver, plen);
SvNVX(ver) = nvval;
/* not the PROTECT bit */
SvFLAGS(ver) |= (SVf_NOK|SVp_NOK|SVf_POK|SVp_POK|SVf_READONLY);
}
static SV *err_to_SV(pTHX_ int err)
{
SV *ret = sv_newmortal();
SvUPGRADE(ret, SVt_PVNV);
if(err) {
const char *error = gai_strerror(err);
sv_setpv(ret, error);
}
else {
sv_setpv(ret, "");
}
SvIV_set(ret, err); SvIOK_on(ret);
return ret;
}
static char *pe_var_start(pe_watcher *_ev, int repeat) {
STRLEN n_a;
struct ufuncs *ufp;
MAGIC **mgp;
MAGIC *mg;
pe_var *ev = (pe_var*) _ev;
SV *sv = ev->variable;
if (!_ev->callback)
return "without callback";
if (!sv || !SvOK(sv))
return "watching what?";
if (!ev->events)
return "without poll events specified";
sv = SvRV(sv);
if (SvREADONLY(sv))
return "cannot trace read-only variable";
(void)SvUPGRADE(sv, SVt_PVMG);
mgp = &SvMAGIC(sv);
while ((mg = *mgp)) {
mgp = &mg->mg_moremagic;
}
EvNew(11, mg, 1, MAGIC);
Zero(mg, 1, MAGIC);
mg->mg_type = 'U';
mg->mg_virtual = &PL_vtbl_uvar;
*mgp = mg;
EvNew(8, ufp, 1, struct ufuncs);
ufp->uf_val = ev->events & PE_R? tracevar_r : 0;
ufp->uf_set = ev->events & PE_W? tracevar_w : 0;
ufp->uf_index = PTR2IV(ev);
mg->mg_ptr = (char *) ufp;
mg->mg_obj = (SV*) ev;
mg_magical(sv);
if (!SvMAGICAL(sv))
return "mg_magical didn't";
return 0;
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
s->var = SvREFCNT_inc(SvRV(arg));
SvGETMAGIC(s->var);
if (!SvPOK(s->var) && SvOK(s->var))
(void)SvPV_nomg_const_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR_set(s->var, 0);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
/*
=for apidoc mro_isa_changed_in
Takes the necessary steps (cache invalidations, mostly)
when the @ISA of the given package has changed. Invoked
by the C<setisa> magic, should not need to invoke directly.
=cut
*/
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
dVAR;
HV* isarev;
AV* linear_mro;
HE* iter;
SV** svp;
I32 items;
bool is_universal;
struct mro_meta * meta;
const char * const stashname = HvNAME_get(stash);
const STRLEN stashname_len = HvNAMELEN_get(stash);
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
if (meta->mro_linear_all) {
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
meta->mro_linear_all = NULL;
/* This is just acting as a shortcut pointer. */
meta->mro_linear_current = NULL;
} else if (meta->mro_linear_current) {
/* Only the current MRO is stored, so this owns the data. */
SvREFCNT_dec(meta->mro_linear_current);
meta->mro_linear_current = NULL;
}
if (meta->isa) {
SvREFCNT_dec(meta->isa);
meta->isa = NULL;
}
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
is_universal = TRUE;
}
else { /* Wipe the local method cache otherwise */
meta->cache_gen++;
is_universal = FALSE;
}
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches */
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 len;
const char* const revkey = hv_iterkey(iter, &len);
HV* revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* revmeta;
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
if (revmeta->mro_linear_all) {
SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
revmeta->mro_linear_all = NULL;
/* This is just acting as a shortcut pointer. */
revmeta->mro_linear_current = NULL;
} else if (revmeta->mro_linear_current) {
/* Only the current MRO is stored, so this owns the data. */
SvREFCNT_dec(revmeta->mro_linear_current);
revmeta->mro_linear_current = NULL;
}
if(!is_universal)
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
if (revmeta->isa) {
SvREFCNT_dec(revmeta->isa);
revmeta->isa = NULL;
}
}
}
/* Now iterate our MRO (parents), and do a few things:
1) instantiate with the "fake" flag if they don't exist
2) flag them as universal if we are universal
3) Add everything from our isarev to their isarev
*/
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create a new SV for
us, then will need to upgrade it to an HV (which sv_upgrade() can
now do for us. */
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
(void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 revkeylen;
char* const revkey = hv_iterkey(iter, &revkeylen);
(void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
}
}
}
}
OP *
Perl_do_readline(pTHX_ GV* gv)
{
dVAR; dSP; dTARGETSTACKED;
register SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
register IO * const io = GvIO(gv);
register const I32 type = PL_op->op_type;
const I32 gimme = GIMME_V;
PERL_ARGS_ASSERT_DO_READLINE;
fp = NULL;
if (io) {
fp = IoIFP(io);
if (!fp) {
if (IoFLAGS(io) & IOf_ARGV) {
if (IoFLAGS(io) & IOf_START) {
IoLINES(io) = 0;
if (av_len(GvAVn(gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_openn(io,"-",1,FALSE,O_RDONLY,0,NULL,NULL,0);
sv_setpvn(GvSVn(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
fp = IoIFP(io);
goto have_fp;
}
}
fp = nextargv(gv);
if (!fp) { /* Note: fp != IoIFP(io) */
(void)do_close(gv, FALSE); /* now it does*/
}
}
}
else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
report_evil_fh(io, OP_phoney_OUTPUT_ONLY);
}
}
if (!fp) {
if ((!io || !(IoFLAGS(io) & IOf_START))
&& ckWARN2(WARN_GLOB, WARN_CLOSED))
{
if (type == OP_GLOB)
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
report_evil_fh(io, PL_op->op_type);
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
if ( ! SvPVOK(TARG) )
sv_upgrade(TARG, SVt_PV);
SvOK_off(TARG);
}
PUSHTARG;
}
RETURN;
}
have_fp:
if (gimme == G_SCALAR) {
sv = TARG;
if (type == OP_RCATLINE) {
NOOP;
}
else {
if ( SvOK(sv) && ! SvPVOK(sv) )
sv_clear_body(sv);
}
if (SvROK(sv)) {
if (type == OP_RCATLINE)
SvPV_force_nolen(sv);
else
sv_unref(sv);
}
else if (isGV_with_GP(sv)) {
SvPV_force_nolen(sv);
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
SvPV_force_nolen(sv);
}
offset = SvCUR(sv);
}
}
else {
sv = sv_2mortal(newSV(80));
offset = 0;
}
/* delay EOF state for a snarfed empty file */
#define SNARF_EOF(gimme,rs,io,sv) \
(gimme != G_SCALAR || SvCUR(sv) \
|| (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
for (;;) {
PUTBACK;
if (!sv_gets(sv, fp, offset)
&& (type == OP_GLOB
|| SNARF_EOF(gimme, PL_rs, io, sv)
|| PerlIO_error(fp)))
{
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
fp = nextargv(gv);
if (fp)
continue;
(void)do_close(gv, FALSE);
}
else if (type == OP_GLOB) {
if (!do_close(gv, FALSE) && ckWARN(WARN_GLOB)) {
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (child exited with status %d%s)",
(int)(STATUS_CURRENT >> 8),
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
}
if (gimme == G_SCALAR) {
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
SvOK_off(TARG);
}
SPAGAIN;
PUSHTARG;
}
RETURN;
}
int
do_aspawn(SV* really, SV **mark, SV **sp)
{
char **a,
*tmps;
struct inheritance inherit;
pid_t pid;
int status,
fd,
nFd,
fdMap[3];
SV *sv,
**p_sv;
STRLEN n_a;
status = FAIL;
if (sp > mark)
{
Newx(PL_Argv, sp - mark + 1, char*);
a = PL_Argv;
while (++mark <= sp)
{
if (*mark)
*a++ = SvPVx(*mark, n_a);
else
*a++ = "";
}
inherit.flags = SPAWN_SETGROUP;
inherit.pgroup = SPAWN_NEWPGROUP;
fdMap[STDIN_FILENO] = Perl_stdin_fd;
fdMap[STDOUT_FILENO] = Perl_stdout_fd;
fdMap[STDERR_FILENO] = STDERR_FILENO;
nFd = 3;
*a = NULL;
/*-----------------------------------------------------*/
/* Will execvp() use PATH? */
/*-----------------------------------------------------*/
if (*PL_Argv[0] != '/')
TAINT_ENV();
if (really && *(tmps = SvPV(really, n_a)))
pid = spawnp(tmps, nFd, fdMap, &inherit,
(const char **) PL_Argv,
(const char **) environ);
else
pid = spawnp(PL_Argv[0], nFd, fdMap, &inherit,
(const char **) PL_Argv,
(const char **) environ);
if (pid < 0)
{
status = FAIL;
if (ckWARN(WARN_EXEC))
warner(WARN_EXEC,"Can't exec \"%s\": %s",
PL_Argv[0],
Strerror(errno));
}
else
{
/*------------------------------------------------*/
/* If the file descriptors have been remapped then*/
/* we've been called following a my_popen request */
/* therefore we don't want to wait for spawnned */
/* program to complete. We need to set the fdpid */
/* value to the value of the spawnned process' pid*/
/*------------------------------------------------*/
fd = 0;
if (Perl_stdin_fd != STDIN_FILENO)
fd = Perl_stdin_fd;
else
if (Perl_stdout_fd != STDOUT_FILENO)
fd = Perl_stdout_fd;
if (fd != 0)
{
/*---------------------------------------------*/
/* Get the fd of the other end of the pipe, */
/* use this to reference the fdpid which will */
/* be used by my_pclose */
/*---------------------------------------------*/
close(fd);
MUTEX_LOCK(&PL_fdpid_mutex);
p_sv = av_fetch(PL_fdpid,fd,TRUE);
fd = (int) SvIVX(*p_sv);
SvREFCNT_dec(*p_sv);
*p_sv = &PL_sv_undef;
sv = *av_fetch(PL_fdpid,fd,TRUE);
MUTEX_UNLOCK(&PL_fdpid_mutex);
(void) SvUPGRADE(sv, SVt_IV);
SvIVX(sv) = pid;
status = 0;
}
else
wait4pid(pid, &status, 0);
}
do_execfree();
}
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
HV* isarev;
AV* linear_mro;
HE* iter;
SV** svp;
I32 items;
bool is_universal;
struct mro_meta * meta;
HV *isa = NULL;
const HEK * const stashhek = HvENAME_HEK(stash);
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
CLEAR_LINEAR(meta);
if (meta->isa) {
/* Steal it for our own purposes. */
isa = (HV *)sv_2mortal((SV *)meta->isa);
meta->isa = NULL;
}
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
svp = hv_fetchhek(PL_isarev, stashhek, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
is_universal = TRUE;
}
else { /* Wipe the local method cache otherwise */
meta->cache_gen++;
is_universal = FALSE;
}
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Changes to @ISA might turn overloading on */
HvAMAGIC_on(stash);
/* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
/* DESTROY can be cached in SvSTASH. */
if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches
and upating PL_isarev. */
if(isarev) {
HV *isa_hashes = NULL;
/* We have to iterate through isarev twice to avoid a chicken and
* egg problem: if A inherits from B and both are in isarev, A might
* be processed before B and use B's previous linearisation.
*/
/* First iteration: Wipe everything, but stash away the isa hashes
* since we still need them for updating PL_isarev.
*/
if(hv_iterinit(isarev)) {
/* Only create the hash if we need it; i.e., if isarev has
any elements. */
isa_hashes = (HV *)sv_2mortal((SV *)newHV());
}
while((iter = hv_iternext(isarev))) {
HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta* revmeta;
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
CLEAR_LINEAR(revmeta);
if(!is_universal)
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
(void)
hv_store(
isa_hashes, (const char*)&revstash, sizeof(HV *),
revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
);
revmeta->isa = NULL;
}
/* Second pass: Update PL_isarev. We can just use isa_hashes to
* avoid another round of stash lookups. */
/* isarev might be deleted from PL_isarev during this loop, so hang
* on to it. */
SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
if(isa_hashes) {
hv_iterinit(isa_hashes);
while((iter = hv_iternext(isa_hashes))) {
HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
HV * const isa = (HV *)HeVAL(iter);
const HEK *namehek;
/* We're starting at the 2nd element, skipping revstash */
linear_mro = mro_get_linear_isa(revstash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
namehek = HvENAME_HEK(revstash);
if (!namehek) namehek = HvNAME_HEK(revstash);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create
a new SV for us, then will need to upgrade it to an
HV (which sv_upgrade() can now do for us). */
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
/* This hash only ever contains PL_sv_yes. Storing it
over itself is almost as cheap as calling hv_exists,
so on aggregate we expect to save time by not making
two calls to the common HV code for the case where
it doesn't exist. */
(void)
hv_storehek(mroisarev, namehek, &PL_sv_yes);
}
if ((SV *)isa != &PL_sv_undef) {
assert(namehek);
mro_clean_isarev(
isa, HEK_KEY(namehek), HEK_LEN(namehek),
HvMROMETA(revstash)->isa, HEK_HASH(namehek),
HEK_UTF8(namehek)
);
}
}
}
}
/* Now iterate our MRO (parents), adding ourselves and everything from
our isarev to their isarev.
*/
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create a new SV for
us, then will need to upgrade it to an HV (which sv_upgrade() can
now do for us. */
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
(void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
}
/* Delete our name from our former parents' isarevs. */
if(isa && HvARRAY(isa))
mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
HEK_HASH(stashhek), HEK_UTF8(stashhek));
}
MP_INLINE static apr_size_t modperl_filter_read(pTHX_
modperl_filter_t *filter,
SV *buffer,
apr_size_t wanted)
{
int num_buckets = 0;
apr_size_t len = 0;
(void)SvUPGRADE(buffer, SVt_PV);
SvCUR(buffer) = 0;
/* calling SvPOK_only here may leave buffer an invalid state since
* SvPVX may be NULL. But it's very likely that something is copied.
* So, we turn the POK flag on here. Later we check if SvPVX is NULL
* and turn the flag off again if so. */
SvPOK_only(buffer);
/* sometimes the EOS bucket arrives in the same brigade with other
* buckets, so that particular read() will not return 0 and will
* be called again if called in the while ($filter->read(...))
* loop. In that case we return 0.
*/
if (filter->seen_eos) {
return 0;
}
/* modperl_brigade_dump(filter->bb_in, NULL); */
MP_TRACE_f(MP_FUNC, MP_FILTER_NAME_FORMAT
"wanted: %db",
MP_FILTER_NAME(filter->f),
wanted);
if (filter->remaining) {
if (filter->remaining >= wanted) {
MP_TRACE_f(MP_FUNC, MP_FILTER_NAME_FORMAT
"eating and returning %d [%s]\n\tof "
"remaining %db",
MP_FILTER_NAME(filter->f),
wanted,
MP_TRACE_STR_TRUNC(filter->pool, filter->leftover, wanted),
filter->remaining);
SvGROW(buffer, wanted+1);
sv_catpvn(buffer, filter->leftover, wanted);
filter->leftover += wanted;
filter->remaining -= wanted;
return wanted;
}
else {
MP_TRACE_f(MP_FUNC, MP_FILTER_NAME_FORMAT
"eating remaining %db",
MP_FILTER_NAME(filter->f),
filter->remaining);
SvGROW(buffer, filter->remaining+1);
sv_catpvn(buffer, filter->leftover, filter->remaining);
len = filter->remaining;
filter->remaining = 0;
filter->leftover = NULL;
}
}
while (1) {
const char *buf;
apr_size_t buf_len;
if (!get_bucket(filter)) {
break;
}
num_buckets++;
filter->rc = apr_bucket_read(filter->bucket, &buf, &buf_len, 0);
if (filter->rc == APR_SUCCESS) {
MP_TRACE_f(MP_FUNC,
MP_FILTER_NAME_FORMAT
"read in: %s bucket with %db (0x%lx)",
MP_FILTER_NAME(filter->f),
filter->bucket->type->name,
buf_len,
(unsigned long)filter->bucket);
}
else {
SvREFCNT_dec(buffer);
modperl_croak(aTHX_ filter->rc, "Apache2::Filter::read");
}
if (buf_len) {
if ((SvCUR(buffer) + buf_len) >= wanted) {
int nibble = wanted - SvCUR(buffer);
SvGROW(buffer, SvCUR(buffer)+nibble+1);
sv_catpvn(buffer, buf, nibble);
filter->leftover = (char *)buf+nibble;
filter->remaining = buf_len - nibble;
len += nibble;
break;
}
else {
len += buf_len;
SvGROW(buffer, SvCUR(buffer)+buf_len+1);
sv_catpvn(buffer, buf, buf_len);
}
}
}
if (!SvPVX(buffer)) {
SvPOK_off(buffer);
}
MP_TRACE_f(MP_FUNC,
MP_FILTER_NAME_FORMAT
"return: %db from %d bucket%s [%s]\n\t(%db leftover)",
MP_FILTER_NAME(filter->f),
len, num_buckets, ((num_buckets == 1) ? "" : "s"),
MP_TRACE_STR_TRUNC(filter->pool, SvPVX(buffer), len),
filter->remaining);
return len;
}
