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;
}
static AV*
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* isa;
const HEK* stashhek;
struct mro_meta* meta;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
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 = meta->mro_linear_c3)) {
return retval;
}
/* not in cache, make a new one */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
if ( isa && ! SvAVOK(isa) ) {
Perl_croak(aTHX_ "@ISA is not an array but %s", Ddesc((SV*)isa));
}
/* For a better idea how the rest of this works, see the much clearer
pure perl version in Algorithm::C3 0.01:
http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
(later versions go about it differently than this code for speed reasons)
*/
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
I32* heads;
/* This builds @seqs, which is an array of arrays.
The members of @seqs are the MROs of
the members of @ISA, followed by @ISA itself.
*/
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
SV* const isa_item = *isa_ptr++;
if ( ! SvPVOK(isa_item) ) {
Perl_croak(aTHX_ "@ISA element which is not an plain value");
}
{
HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
/* if no stash, make a temporary fake MRO
containing just itself */
AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
av_push(seqs, (SV*)isa_lin);
}
else {
/* recursion */
AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
av_push(seqs, SvREFCNT_inc_NN((SV*)isa_lin));
}
}
}
av_push(seqs, SvREFCNT_inc_NN((SV*)isa));
/* This builds "heads", which as an array of integer array
indices, one per seq, which point at the virtual "head"
of the seq (initially zero) */
Newxz(heads, AvFILLp(seqs)+1, I32);
/* This builds %tails, which has one key for every class
mentioned in the tail of any sequence in @seqs (tail meaning
everything after the first class, the "head"). The value
is how many times this key appears in the tails of @seqs.
*/
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
AV *const seq = MUTABLE_AV(*seqs_ptr++);
I32 seq_items = AvFILLp(seq);
if(seq_items > 0) {
SV** seq_ptr = AvARRAY(seq) + 1;
while(seq_items--) {
SV* const seqitem = *seq_ptr++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
if(he) {
SV* const val = HeVAL(he);
/* This will increment undef to 1, which is what we
want for a newly created entry. */
sv_inc(val);
}
}
}
}
/* Initialize retval to build the return value in */
retval = newAV();
av_push(retval, newSVhek(stashhek)); /* us first */
/* This loop won't terminate until we either finish building
the MRO, or get an exception. */
while(1) {
SV* cand = NULL;
SV* winner = NULL;
int s;
/* "foreach $seq (@seqs)" */
SV** const avptr = AvARRAY(seqs);
for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
AV * const seq = MUTABLE_AV(avptr[s]);
SV* seqhead;
if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
seqhead = *svp; /* seqhead = head of this seq */
if(!winner) {
HE* tail_entry;
SV* val;
/* if we haven't found a winner for this round yet,
and this seqhead is not in tails (or the count
for it in tails has dropped to zero), then this
seqhead is our new winner, and is added to the
final MRO immediately */
cand = seqhead;
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
&& (val = HeVAL(tail_entry))
&& (SvIV(val) > 0))
continue;
winner = newSVsv(cand);
av_push(retval, winner);
/* note however that even when we find a winner,
we continue looping over @seqs to do housekeeping */
}
if(!sv_cmp(seqhead, winner)) {
/* Once we have a winner (including the iteration
where we first found him), inc the head ptr
for any seq which had the winner as a head,
NULL out any seq which is now empty,
and adjust tails for consistency */
const int new_head = ++heads[s];
if(new_head > AvFILLp(seq)) {
SvREFCNT_dec(avptr[s]);
avptr[s] = NULL;
}
else {
HE* tail_entry;
SV* val;
/* Because we know this new seqhead used to be
a tail, we can assume it is in tails and has
a positive value, which we need to dec */
svp = av_fetch(seq, new_head, 0);
seqhead = *svp;
tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
val = HeVAL(tail_entry);
sv_dec(val);
}
}
}
/* if we found no candidates, we are done building the MRO.
!cand means no seqs have any entries left to check */
if(!cand) {
Safefree(heads);
break;
}
/* If we had candidates, but nobody won, then the @ISA
hierarchy is not C3-incompatible */
if(!winner) {
SV *errmsg;
I32 i;
errmsg = newSVpvf(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s':\n\t"
"current merge results [\n", HEK_KEY(stashhek));
for (i = 0; i <= av_len(retval); i++) {
SV **elem = av_fetch(retval, i, 0);
sv_catpvf(aTHX_ errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
}
sv_catpvf(aTHX_ errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
/* we have to do some cleanup before we croak */
AvREFCNT_dec(retval);
Safefree(heads);
croak(aTHX_ "%"SVf, SVfARG(errmsg));
}
}
}
else { /* @ISA was undefined or empty */
/* build a retval containing only ourselves */
retval = newAV();
av_push(retval, newSVhek(stashhek));
}
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
meta->mro_linear_c3 = retval;
return retval;
}
