/* pp_ctl.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
+
PP(pp_wantarray)
{
dVAR;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
SV *tmpstr;
MAGIC *mg = NULL;
+ regexp * re;
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
tmpstr = POPs;
if (SvROK(tmpstr)) {
- SV *sv = SvRV(tmpstr);
+ SV * const sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
mg = mg_find(sv, PERL_MAGIC_qr);
}
if (mg) {
- regexp * const re = (regexp *)mg->mg_obj;
+ regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, ReREFCNT_inc(re));
+ PM_SETRE(pm, re);
}
else {
STRLEN len;
- const char *t = SvPV_const(tmpstr, len);
+ const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
+ re = PM_GETRE(pm);
/* Check against the last compiled regexp. */
- if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
- PM_GETRE(pm)->prelen != (I32)len ||
- memNE(PM_GETRE(pm)->precomp, t, len))
+ if (!re || !re->precomp || re->prelen != (I32)len ||
+ memNE(re->precomp, t, len))
{
- if (PM_GETRE(pm)) {
- ReREFCNT_dec(PM_GETRE(pm));
+ const regexp_engine *eng = re ? re->engine : NULL;
+ U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
+ if (re) {
+ ReREFCNT_dec(re);
PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
+ } else if (PL_curcop->cop_hints_hash) {
+ SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
+ "regcomp", 7, 0, 0);
+ if (ptr && SvIOK(ptr) && SvIV(ptr))
+ eng = INT2PTR(regexp_engine*,SvIV(ptr));
}
+
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
- pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
if (DO_UTF8(tmpstr))
- pm->op_pmdynflags |= PMdf_DYN_UTF8;
- else {
- pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
- if (pm->op_pmdynflags & PMdf_UTF8)
- t = (char*)bytes_to_utf8((U8*)t, &len);
- }
- PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
- if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
- Safefree(t);
+ pm_flags |= RXf_UTF8;
+
+ if (eng)
+ PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
+ else
+ PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
+
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
inside tie/overload accessors. */
}
}
+
+ re = PM_GETRE(pm);
#ifndef INCOMPLETE_TAINTS
if (PL_tainting) {
if (PL_tainted)
- pm->op_pmdynflags |= PMdf_TAINTED;
+ re->extflags |= RXf_TAINTED;
else
- pm->op_pmdynflags &= ~PMdf_TAINTED;
+ re->extflags &= ~RXf_TAINTED;
}
#endif
if (!PM_GETRE(pm)->prelen && PL_curpm)
pm = PL_curpm;
- else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
- pm->op_pmflags |= PMf_WHITE;
- else
- pm->op_pmflags &= ~PMf_WHITE;
- /* XXX runtime compiled output needs to move to the pad */
+
+#if !defined(USE_ITHREADS)
+ /* can't change the optree at runtime either */
+ /* PMf_KEEP is handled differently under threads to avoid these problems */
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
-#if !defined(USE_ITHREADS)
- /* XXX can't change the optree at runtime either */
cLOGOP->op_first->op_next = PL_op->op_next;
-#endif
}
+#endif
RETURN;
}
if(old != rx) {
if(old)
ReREFCNT_dec(old);
- PM_SETRE(pm,rx);
+ PM_SETRE(pm,ReREFCNT_inc(rx));
}
rxres_restore(&cx->sb_rxres, rx);
FREETMPS; /* Prevent excess tmp stack */
/* Are we done */
- if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
+ if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
s == m, cx->sb_targ, NULL,
((cx->sb_rflags & REXEC_COPY_STR)
? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
if (DO_UTF8(dstr))
SvUTF8_on(targ);
SvPV_set(dstr, NULL);
- sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
PUSHs(sv_2mortal(newSViv(saviters - 1)));
SvTAINT(targ);
LEAVE_SCOPE(cx->sb_oldsave);
- ReREFCNT_dec(rx);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
s = orig + (m - s);
cx->sb_strend = s + (cx->sb_strend - m);
}
- cx->sb_m = m = rx->startp[0] + orig;
+ cx->sb_m = m = rx->offs[0].start + orig;
if (m > s) {
if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
else
sv_catpvn(dstr, s, m-s);
}
- cx->sb_s = rx->endp[0] + orig;
+ cx->sb_s = rx->offs[0].end + orig;
{ /* Update the pos() information. */
SV * const sv = cx->sb_targ;
MAGIC *mg;
I32 i;
- if (SvTYPE(sv) < SVt_PVMG)
- SvUPGRADE(sv, SVt_PVMG);
+ SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(lsv))
+ if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
(void)ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
- RETURNOP(pm->op_pmreplstart);
+ RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
}
void
*p++ = PTR2UV(rx->subbeg);
*p++ = (UV)rx->sublen;
for (i = 0; i <= rx->nparens; ++i) {
- *p++ = (UV)rx->startp[i];
- *p++ = (UV)rx->endp[i];
+ *p++ = (UV)rx->offs[i].start;
+ *p++ = (UV)rx->offs[i].end;
}
}
rx->subbeg = INT2PTR(char*,*p++);
rx->sublen = (I32)(*p++);
for (i = 0; i <= rx->nparens; ++i) {
- rx->startp[i] = (I32)(*p++);
- rx->endp[i] = (I32)(*p++);
+ rx->offs[i].start = (I32)(*p++);
+ rx->offs[i].end = (I32)(*p++);
}
}
case FF_0DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
- fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
+ fmt = (const char *)
+ ((arg & 256) ?
+ "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
#else
- fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
+ fmt = (const char *)
+ ((arg & 256) ?
+ "%#0*.*f" : "%0*.*f");
#endif
goto ff_dec;
case FF_DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
- fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
+ fmt = (const char *)
+ ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
#else
- fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
+ fmt = (const char *)
+ ((arg & 256) ? "%#*.*f" : "%*.*f");
#endif
ff_dec:
/* If the field is marked with ^ and the value is undefined,
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
- sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
+ my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
}
STATIC I32
-S_dopoptosub(pTHX_ I32 startingblock)
-{
- dVAR;
- return dopoptosub_at(cxstack, startingblock);
-}
-
-STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
dVAR;
else if (PL_errors)
sv_catsv(PL_errors, err);
else
- Perl_warn(aTHX_ "%"SVf, err);
- ++PL_error_count;
+ Perl_warn(aTHX_ "%"SVf, SVfARG(err));
+ if (PL_parser)
+ ++PL_parser->error_count;
}
OP *
if (CxTYPE(cx) != CXt_EVAL) {
if (!message)
message = SvPVx_const(ERRSV, msglen);
- PerlIO_write(Perl_error_log, "panic: die ", 11);
+ PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
}
PUSHs(sv_2mortal(mask));
}
- PUSHs(cx->blk_oldcop->cop_hints ?
+ PUSHs(cx->blk_oldcop->cop_hints_hash ?
sv_2mortal(newRV_noinc(
- (SV*)Perl_refcounted_he_chain_2hv(aTHX_
- cx->blk_oldcop->cop_hints)))
+ (SV*)Perl_refcounted_he_chain_2hv(aTHX_
+ cx->blk_oldcop->cop_hints_hash)))
: &PL_sv_undef);
RETURN;
}
{
dVAR;
dSP;
- const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
+ const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
sv_reset(tmps, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
SV **svp;
- U32 cxtype = CXt_LOOP | CXp_FOREACH;
+ U16 cxtype = CXt_LOOP | CXp_FOREACH;
#ifdef USE_ITHREADS
void *iterdata;
#endif
TAINT_NOT;
if (gimme == G_VOID)
- /*EMPTY*/; /* do nothing */
+ NOOP;
else if (gimme == G_SCALAR) {
if (mark < SP)
*++newsp = sv_mortalcopy(*SP);
/* Unassume the success we assumed earlier. */
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%"SVf" did not return a true value", nsv);
+ DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
}
break;
case CXt_FORMAT:
case CXt_LOOP:
pop2 = CXt_LOOP;
newsp = PL_stack_base + cx->blk_loop.resetsp;
- nextop = cx->blk_loop.last_op->op_next;
+ nextop = cx->blk_loop.my_op->op_lastop->op_next;
break;
case CXt_SUB:
pop2 = CXt_SUB;
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
PL_curcop = cx->blk_oldcop;
- return cx->blk_loop.next_op;
+ return CX_LOOP_NEXTOP_GET(cx);
}
PP(pp_redo)
if (cxix < cxstack_ix)
dounwind(cxix);
- redo_op = cxstack[cxix].blk_loop.redo_op;
+ redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
/* pop one less context to avoid $x being freed in while (my $x..) */
cxstack_ix++;
goto retry;
tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
- DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
}
DIE(aTHX_ "Goto undefined subroutine");
}
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
- SvREFCNT_inc_void_NN(cv);
+ SvREFCNT_inc_simple_void_NN(cv);
else {
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
SV **ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
if (items >= AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items+1,SV*);
AvALLOC(av) = ary;
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
}
++mark;
}
}
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
- /*
- * We do not care about using sv to call CV;
- * it's for informational purposes only.
- */
- SV * const sv = GvSV(PL_DBsub);
- save_item(sv);
- if (PERLDB_SUB_NN) {
- const int type = SvTYPE(sv);
- if (type < SVt_PVIV && type != SVt_IV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
- } else {
- gv_efullname3(sv, CvGV(cv), NULL);
- }
+ Perl_get_db_sub(aTHX_ NULL, cv);
if (PERLDB_GOTO) {
CV * const gotocv = get_cv("DB::goto", FALSE);
if (gotocv) {
while (s && s < send) {
const char *t;
- SV * const tmpstr = newSV(0);
+ SV * const tmpstr = newSV_type(SVt_PVMG);
- sv_upgrade(tmpstr, SVt_PVMG);
t = strchr(s, '\n');
if (t)
t++;
I32 gimme = G_VOID;
I32 optype;
OP dummy;
- OP *rop;
char tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
STRLEN len;
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
len = SvCUR(sv);
}
else
- len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
- (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
+ (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
PUSHEVAL(cx, 0, NULL);
if (runtime)
- rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+ (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
else
- rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
+ (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
- return rop;
+ return PL_eval_start;
}
* In the last case, startop is non-null, and contains the address of
* a pointer that should be set to the just-compiled code.
* outside is the lexically enclosing CV (if any) that invoked us.
+ * Returns a bool indicating whether the compile was successful; if so,
+ * PL_eval_start contains the first op of the compiled ocde; otherwise,
+ * pushes undef (also croaks if startop != NULL).
*/
-/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
-STATIC OP *
+STATIC bool
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dVAR; dSP;
PUSHMARK(SP);
SAVESPTR(PL_compcv);
- PL_compcv = (CV*)newSV(0);
- sv_upgrade((SV *)PL_compcv, SVt_PVCV);
+ PL_compcv = (CV*)newSV_type(SVt_PVCV);
CvEVAL_on(PL_compcv);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
/* set up a scratch pad */
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+ PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
if (!PL_madskills)
SAVESPTR(PL_curstash);
PL_curstash = CopSTASH(PL_curcop);
}
+ /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
SAVESPTR(PL_beginav);
PL_beginav = newAV();
SAVEFREESV(PL_beginav);
- SAVEI32(PL_error_count);
+ SAVESPTR(PL_unitcheckav);
+ PL_unitcheckav = newAV();
+ SAVEFREESV(PL_unitcheckav);
#ifdef PERL_MAD
- SAVEI32(PL_madskills);
+ SAVEBOOL(PL_madskills);
PL_madskills = 0;
#endif
/* try to compile it */
PL_eval_root = NULL;
- PL_error_count = 0;
PL_curcop = &PL_compiling;
CopARYBASE_set(PL_curcop, 0);
if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
sv_setpvn(ERRSV,"",0);
- if (yyparse() || PL_error_count || !PL_eval_root) {
+ if (yyparse() || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
I32 optype = 0; /* Might be reset by POPEVAL. */
const SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
- DIE(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%sCompilation failed in require",
+ *msg ? msg : "Unknown error\n");
}
else if (startop) {
POPBLOCK(cx,PL_curpm);
}
else {
if (!*msg) {
- sv_setpv(ERRSV, "Compilation error");
+ sv_setpvs(ERRSV, "Compilation error");
}
}
PERL_UNUSED_VAR(newsp);
- RETPUSHUNDEF;
+ PUSHs(&PL_sv_undef);
+ PUTBACK;
+ return FALSE;
}
CopLINE_set(&PL_compiling, 0);
if (startop) {
DEBUG_x(dump_eval());
/* Register with debugger: */
- if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
+ if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
CV * const cv = get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
}
}
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+
/* compiled okay, so do it */
CvDEPTH(PL_compcv) = 1;
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
- PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
+ PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
- RETURNOP(PL_eval_start);
+ PUTBACK;
+ return TRUE;
}
STATIC PerlIO *
{
Stat_t st;
const int st_rc = PerlLIO_stat(name, &st);
+
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
return NULL;
}
SV *sv;
const char *name;
STRLEN len;
+ char * unixname;
+ STRLEN unixlen;
+#ifdef VMS
+ int vms_unixname = 0;
+#endif
const char *tryname = NULL;
SV *namesv = NULL;
const I32 gimme = GIMME_V;
int filter_has_file = 0;
PerlIO *tryrsfp = NULL;
- GV *filter_child_proc = NULL;
+ SV *filter_cache = NULL;
SV *filter_state = NULL;
SV *filter_sub = NULL;
SV *hook_sv = NULL;
sv = POPs;
if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
- if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
+ if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) { /* require v5.6.1 */
+ HV * hinthv = GvHV(PL_hintgv);
+ SV ** ptr = NULL;
+ if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
+ if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
"v-string in use/require non-portable");
-
+ }
sv = new_version(sv);
if (!sv_derived_from(PL_patchlevel, "version"))
- upg_version(PL_patchlevel);
+ upg_version(PL_patchlevel, TRUE);
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
- if ( vcmp(sv,PL_patchlevel) < 0 )
+ if ( vcmp(sv,PL_patchlevel) <= 0 )
DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
- vnormal(sv), vnormal(PL_patchlevel));
+ SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
}
else {
- if ( vcmp(sv,PL_patchlevel) > 0 )
- DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
- vnormal(sv), vnormal(PL_patchlevel));
+ if ( vcmp(sv,PL_patchlevel) > 0 ) {
+ I32 first = 0;
+ AV *lav;
+ SV * const req = SvRV(sv);
+ SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
+
+ /* get the left hand term */
+ lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
+
+ first = SvIV(*av_fetch(lav,0,0));
+ if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
+ || hv_exists((HV*)req, "qv", 2 ) /* qv style */
+ || av_len(lav) > 1 /* FP with > 3 digits */
+ || strstr(SvPVX(pv),".0") /* FP with leading 0 */
+ ) {
+ DIE(aTHX_ "Perl %"SVf" required--this is only "
+ "%"SVf", stopped", SVfARG(vnormal(req)),
+ SVfARG(vnormal(PL_patchlevel)));
+ }
+ else { /* probably 'use 5.10' or 'use 5.8' */
+ SV * hintsv = newSV(0);
+ I32 second = 0;
+
+ if (av_len(lav)>=1)
+ second = SvIV(*av_fetch(lav,1,0));
+
+ second /= second >= 600 ? 100 : 10;
+ hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
+ (int)first, (int)second,0);
+ upg_version(hintsv, TRUE);
+
+ DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
+ "--this is only %"SVf", stopped",
+ SVfARG(vnormal(req)),
+ SVfARG(vnormal(hintsv)),
+ SVfARG(vnormal(PL_patchlevel)));
+ }
+ }
}
- RETPUSHYES;
+ /* We do this only with use, not require. */
+ if (PL_compcv &&
+ /* If we request a version >= 5.6.0, then v-string are OK
+ so set $^H{v_string} to suppress the v-string warning */
+ vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
+ HV * hinthv = GvHV(PL_hintgv);
+ if( hinthv ) {
+ SV *hint = newSViv(1);
+ (void)hv_stores(hinthv, "v_string", hint);
+ /* This will call through to Perl_magic_sethint() which in turn
+ sets PL_hints correctly. */
+ SvSETMAGIC(hint);
+ }
+ /* If we request a version >= 5.9.5, load feature.pm with the
+ * feature bundle that corresponds to the required version. */
+ if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
+ SV *const importsv = vnormal(sv);
+ *SvPVX_mutable(importsv) = ':';
+ ENTER;
+ Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
+ LEAVE;
+ }
+ }
+
+ RETPUSHYES;
}
name = SvPV_const(sv, len);
if (!(name && len > 0 && *name))
DIE(aTHX_ "Null filename used");
TAINT_PROPER("require");
+
+
+#ifdef VMS
+ /* The key in the %ENV hash is in the syntax of file passed as the argument
+ * usually this is in UNIX format, but sometimes in VMS format, which
+ * can result in a module being pulled in more than once.
+ * To prevent this, the key must be stored in UNIX format if the VMS
+ * name can be translated to UNIX.
+ */
+ if ((unixname = tounixspec(name, NULL)) != NULL) {
+ unixlen = strlen(unixname);
+ vms_unixname = 1;
+ }
+ else
+#endif
+ {
+ /* if not VMS or VMS name can not be translated to UNIX, pass it
+ * through.
+ */
+ unixname = (char *) name;
+ unixlen = len;
+ }
if (PL_op->op_type == OP_REQUIRE) {
- SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
+ unixname, unixlen, 0);
if ( svp ) {
if (*svp != &PL_sv_undef)
RETPUSHYES;
else
- DIE(aTHX_ "Compilation failed in require");
+ DIE(aTHX_ "Attempt to reload %s aborted.\n"
+ "Compilation failed in require", unixname);
}
}
AV * const ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
- char *unixname;
- if ((unixname = tounixspec(name, NULL)) != NULL)
+ if (vms_unixname)
#endif
{
namesv = newSV(0);
for (i = 0; i <= AvFILL(ar); i++) {
- SV *dirsv = *av_fetch(ar, i, TRUE);
+ SV * const dirsv = *av_fetch(ar, i, TRUE);
+ if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
+ mg_get(dirsv);
if (SvROK(dirsv)) {
int count;
+ SV **svp;
SV *loader = dirsv;
if (SvTYPE(SvRV(loader)) == SVt_PVAV
count = call_sv(loader, G_ARRAY);
SPAGAIN;
+ /* Adjust file name if the hook has set an %INC entry */
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (svp)
+ tryname = SvPVX_const(*svp);
+
if (count > 0) {
int i = 0;
SV *arg;
SP -= count - 1;
arg = SP[i++];
+ if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
+ && !isGV_with_GP(SvRV(arg))) {
+ filter_cache = SvRV(arg);
+ SvREFCNT_inc_simple_void_NN(filter_cache);
+
+ if (i < count) {
+ arg = SP[i++];
+ }
+ }
+
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
arg = SvRV(arg);
}
if (SvTYPE(arg) == SVt_PVGV) {
- IO *io = GvIO((GV *)arg);
+ IO * const io = GvIO((GV *)arg);
++filter_has_file;
if (io) {
tryrsfp = IoIFP(io);
- if (IoTYPE(io) == IoTYPE_PIPE) {
- /* reading from a child process doesn't
- nest -- when returning from reading
- the inner module, the outer one is
- unreadable (closed?) I've tried to
- save the gv to manage the lifespan of
- the pipe, but this didn't help. XXX */
- filter_child_proc = (GV *)arg;
- SvREFCNT_inc_simple_void(filter_child_proc);
- }
- else {
- if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
- PerlIO_close(IoOFP(io));
- }
- IoIFP(io) = NULL;
- IoOFP(io) = NULL;
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ PerlIO_close(IoOFP(io));
}
+ IoIFP(io) = NULL;
+ IoOFP(io) = NULL;
}
if (i < count) {
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
filter_sub = arg;
- SvREFCNT_inc_void_NN(filter_sub);
+ SvREFCNT_inc_simple_void_NN(filter_sub);
if (i < count) {
filter_state = SP[i];
SvREFCNT_inc_simple_void(filter_state);
}
+ }
- if (!tryrsfp) {
- tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
- }
+ if (!tryrsfp && (filter_cache || filter_sub)) {
+ tryrsfp = PerlIO_open(BIT_BUCKET,
+ PERL_SCRIPT_MODE);
}
SP--;
}
}
filter_has_file = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- filter_child_proc = NULL;
+ if (filter_cache) {
+ SvREFCNT_dec(filter_cache);
+ filter_cache = NULL;
}
if (filter_state) {
SvREFCNT_dec(filter_state);
|| (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
#endif
) {
- const char *dir = SvPVx_nolen_const(dirsv);
+ const char *dir = SvOK(dirsv) ? SvPV_nolen_const(dirsv) : "";
#ifdef MACOS_TRADITIONAL
char buf1[256];
char buf2[256];
tryname += 2;
break;
}
+ else if (errno == EMFILE)
+ /* no point in trying other paths if out of handles */
+ break;
}
}
}
/* name is never assigned to again, so len is still strlen(name) */
/* Check whether a hook in @INC has already filled %INC */
if (!hook_sv) {
- (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
+ (void)hv_store(GvHVn(PL_incgv),
+ unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
} else {
- SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
if (!svp)
- (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
+ (void)hv_store(GvHVn(PL_incgv),
+ unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
ENTER;
SAVETMPS;
- lex_start(sv_2mortal(newSVpvs("")));
- SAVEGENERICSV(PL_rsfp_filters);
- PL_rsfp_filters = NULL;
+ lex_start(NULL, tryrsfp, TRUE);
- PL_rsfp = tryrsfp;
SAVEHINTS();
PL_hints = 0;
- SAVECOPWARNINGS(&PL_compiling);
+ SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
PL_compiling.cop_warnings = pWARN_NONE ;
- else if (PL_taint_warn) {
- PL_compiling.cop_warnings
- = Perl_new_warnings_bitfield(NULL, WARN_TAINTstring, WARNsize);
- }
else
PL_compiling.cop_warnings = pWARN_STD ;
- SAVESPTR(PL_compiling.cop_io);
- PL_compiling.cop_io = NULL;
- if (filter_sub || filter_child_proc) {
+ if (filter_sub || filter_cache) {
SV * const datasv = filter_add(S_run_user_filter, NULL);
IoLINES(datasv) = filter_has_file;
- IoFMT_GV(datasv) = (GV *)filter_child_proc;
IoTOP_GV(datasv) = (GV *)filter_state;
IoBOTTOM_GV(datasv) = (GV *)filter_sub;
+ IoFMT_GV(datasv) = (GV *)filter_cache;
}
/* switch to eval mode */
encoding = PL_encoding;
PL_encoding = NULL;
- op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
+ if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
+ op = DOCATCH(PL_eval_start);
+ else
+ op = PL_op->op_next;
/* Restore encoding. */
PL_encoding = encoding;
char *tmpbuf = tbuf;
char *safestr;
STRLEN len;
- OP *ret;
+ bool ok;
CV* runcv;
U32 seq;
HV *saved_hh = NULL;
+ const char * const fakestr = "_<(eval )";
+ const int fakelen = 9 + 1;
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = (HV*) SvREFCNT_inc(POPs);
}
sv = POPs;
- if (!SvPV_nolen_const(sv))
- RETPUSHUNDEF;
+ TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
len = SvCUR(temp_sv);
}
else
- len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
PL_hints = PL_op->op_targ;
if (saved_hh)
GvHV(PL_hintgv) = saved_hh;
- SAVECOPWARNINGS(&PL_compiling);
+ SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- SAVESPTR(PL_compiling.cop_io);
- if (specialCopIO(PL_curcop->cop_io))
- PL_compiling.cop_io = PL_curcop->cop_io;
- else {
- PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
- SAVEFREESV(PL_compiling.cop_io);
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
}
- if (PL_compiling.cop_hints) {
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
- }
- PL_compiling.cop_hints = PL_curcop->cop_hints;
- if (PL_compiling.cop_hints) {
+ PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
+ if (PL_compiling.cop_hints_hash) {
HINTS_REFCNT_LOCK;
- PL_compiling.cop_hints->refcounted_he_refcnt++;
+ PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
HINTS_REFCNT_UNLOCK;
}
/* special case: an eval '' executed within the DB package gets lexically
/* prepare to compile string */
if (PERLDB_LINE && PL_curstash != PL_debstash)
- save_lines(CopFILEAV(&PL_compiling), PL_linestr);
+ save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
PUTBACK;
- ret = doeval(gimme, NULL, runcv, seq);
+ ok = doeval(gimme, NULL, runcv, seq);
if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
- && ret != PL_op->op_next) { /* Successive compilation. */
- strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ && ok) {
+ /* Copy in anything fake and short. */
+ my_strlcpy(safestr, fakestr, fakelen);
}
- return DOCATCH(ret);
+ return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
}
PP(pp_leaveeval)
/* Unassume the success we assumed earlier. */
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
+ retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
/* die_where() did LEAVE, or we won't be here */
}
else {
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0, 0);
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
PP(pp_entertry)
{
dVAR;
- PERL_CONTEXT *cx = create_eval_scope(0);
+ PERL_CONTEXT * const cx = create_eval_scope(0);
cx->blk_eval.retop = cLOGOP->op_other->op_next;
return DOCATCH(PL_op->op_next);
}
}
/* Helper routines used by pp_smartmatch */
-STATIC
-PMOP *
+STATIC PMOP *
S_make_matcher(pTHX_ regexp *re)
{
dVAR;
return matcher;
}
-STATIC
-bool
+STATIC bool
S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
{
dVAR;
return (SvTRUEx(POPs));
}
-STATIC
-void
+STATIC void
S_destroy_matcher(pTHX_ PMOP *matcher)
{
dVAR;
return do_smartmatch(NULL, NULL);
}
-/* This version of do_smartmatch() implements the following
- table of smart matches:
-
- $a $b Type of Match Implied Matching Code
- ====== ===== ===================== =============
- (overloading trumps everything)
-
- Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
- Any Code[+] scalar sub truth match if $b->($a)
-
- Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
- Hash Array hash value slice truth match if $a->{any(@$b)}
- Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
- Hash Any hash entry existence match if exists $a->{$b}
-
- Array Array arrays are identical[*] match if $a È~~Ç $b
- Array Regex array grep match if any(@$a) =~ /$b/
- Array Num array contains number match if any($a) == $b
- Array Any array contains string match if any($a) eq $b
-
- Any undef undefined match if !defined $a
- Any Regex pattern match match if $a =~ /$b/
- Code() Code() results are equal match if $a->() eq $b->()
- Any Code() simple closure truth match if $b->() (ignoring $a)
- Num numish[!] numeric equality match if $a == $b
- Any Str string equality match if $a eq $b
- Any Num numeric equality match if $a == $b
-
- Any Any string equality match if $a eq $b
-
-
- + - this must be a code reference whose prototype (if present) is not ""
- (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
- * - if a circular reference is found, we fall back to referential equality
- ! - either a real number, or a string that looks_like_number()
-
+/* This version of do_smartmatch() implements the
+ * table of smart matches that is found in perlsyn.
*/
-STATIC
-OP *
+STATIC OP *
S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
{
dVAR;
SV *e = TOPs; /* e is for 'expression' */
SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
- SV *this, *other;
+ SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
MAGIC *mg;
regexp *this_regex, *other_regex;
# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
# define SM_REF(type) ( \
- (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
- || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
+ (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
+ || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
# define SM_CV_NEP /* Find a code ref without an empty prototype */ \
- ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
- && NOT_EMPTY_PROTO(this) && (other = e)) \
- || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
- && NOT_EMPTY_PROTO(this) && (other = d)))
+ ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
+ && NOT_EMPTY_PROTO(This) && (Other = e)) \
+ || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
+ && NOT_EMPTY_PROTO(This) && (Other = d)))
# define SM_REGEX ( \
- (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
- && (mg = mg_find(this, PERL_MAGIC_qr)) \
+ (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
+ && (mg = mg_find(This, PERL_MAGIC_qr)) \
&& (this_regex = (regexp *)mg->mg_obj) \
- && (other = e)) \
+ && (Other = e)) \
|| \
- (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
- && (mg = mg_find(this, PERL_MAGIC_qr)) \
+ (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
+ && (mg = mg_find(This, PERL_MAGIC_qr)) \
&& (this_regex = (regexp *)mg->mg_obj) \
- && (other = d)) )
+ && (Other = d)) )
# define SM_OTHER_REF(type) \
- (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
+ (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
-# define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
- && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
+# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
+ && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
&& (other_regex = (regexp *)mg->mg_obj))
if (SM_CV_NEP) {
I32 c;
- if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
+ if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
{
- if (this == SvRV(other))
+ if (This == SvRV(Other))
RETPUSHYES;
else
RETPUSHNO;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- PUSHs(other);
+ PUSHs(Other);
PUTBACK;
- c = call_sv(this, G_SCALAR);
+ c = call_sv(This, G_SCALAR);
SPAGAIN;
if (c == 0)
PUSHs(&PL_sv_no);
else if (SvTEMP(TOPs))
- SvREFCNT_inc(TOPs);
+ SvREFCNT_inc_void(TOPs);
FREETMPS;
LEAVE;
RETURN;
if (SM_OTHER_REF(PVHV)) {
/* Check that the key-sets are identical */
HE *he;
- HV *other_hv = (HV *) SvRV(other);
+ HV *other_hv = (HV *) SvRV(Other);
bool tied = FALSE;
bool other_tied = FALSE;
U32 this_key_count = 0,
other_key_count = 0;
/* Tied hashes don't know how many keys they have. */
- if (SvTIED_mg(this, PERL_MAGIC_tied)) {
+ if (SvTIED_mg(This, PERL_MAGIC_tied)) {
tied = TRUE;
}
else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
HV * const temp = other_hv;
- other_hv = (HV *) this;
- this = (SV *) temp;
+ other_hv = (HV *) This;
+ This = (SV *) temp;
tied = TRUE;
}
if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
other_tied = TRUE;
- if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
+ if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
RETPUSHNO;
/* The hashes have the same number of keys, so it suffices
to check that one is a subset of the other. */
- (void) hv_iterinit((HV *) this);
- while ( (he = hv_iternext((HV *) this)) ) {
+ (void) hv_iterinit((HV *) This);
+ while ( (he = hv_iternext((HV *) This)) ) {
I32 key_len;
char * const key = hv_iterkey(he, &key_len);
++ this_key_count;
if(!hv_exists(other_hv, key, key_len)) {
- (void) hv_iterinit((HV *) this); /* reset iterator */
+ (void) hv_iterinit((HV *) This); /* reset iterator */
RETPUSHNO;
}
}
RETPUSHYES;
}
else if (SM_OTHER_REF(PVAV)) {
- AV * const other_av = (AV *) SvRV(other);
+ AV * const other_av = (AV *) SvRV(Other);
const I32 other_len = av_len(other_av) + 1;
I32 i;
- if (HvUSEDKEYS((HV *) this) != other_len)
+ if (HvUSEDKEYS((HV *) This) != other_len)
RETPUSHNO;
for(i = 0; i < other_len; ++i) {
RETPUSHNO;
key = SvPV(*svp, key_len);
- if(!hv_exists((HV *) this, key, key_len))
+ if(!hv_exists((HV *) This, key, key_len))
RETPUSHNO;
}
RETPUSHYES;
PMOP * const matcher = make_matcher(other_regex);
HE *he;
- (void) hv_iterinit((HV *) this);
- while ( (he = hv_iternext((HV *) this)) ) {
+ (void) hv_iterinit((HV *) This);
+ while ( (he = hv_iternext((HV *) This)) ) {
if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
- (void) hv_iterinit((HV *) this);
+ (void) hv_iterinit((HV *) This);
destroy_matcher(matcher);
RETPUSHYES;
}
RETPUSHNO;
}
else {
- if (hv_exists_ent((HV *) this, other, 0))
+ if (hv_exists_ent((HV *) This, Other, 0))
RETPUSHYES;
else
RETPUSHNO;
}
else if (SM_REF(PVAV)) {
if (SM_OTHER_REF(PVAV)) {
- AV *other_av = (AV *) SvRV(other);
- if (av_len((AV *) this) != av_len(other_av))
+ AV *other_av = (AV *) SvRV(Other);
+ if (av_len((AV *) This) != av_len(other_av))
RETPUSHNO;
else {
I32 i;
(void) sv_2mortal((SV *) seen_other);
}
for(i = 0; i <= other_len; ++i) {
- SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
+ SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
SV * const * const other_elem = av_fetch(other_av, i, FALSE);
if (!this_elem || !other_elem) {
RETPUSHNO;
}
else {
- hv_store_ent(seen_this,
- sv_2mortal(newSViv(PTR2IV(*this_elem))),
- &PL_sv_undef, 0);
- hv_store_ent(seen_other,
- sv_2mortal(newSViv(PTR2IV(*other_elem))),
- &PL_sv_undef, 0);
+ (void)hv_store_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))),
+ &PL_sv_undef, 0);
+ (void)hv_store_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))),
+ &PL_sv_undef, 0);
PUSHs(*this_elem);
PUSHs(*other_elem);
}
else if (SM_OTHER_REGEX) {
PMOP * const matcher = make_matcher(other_regex);
- const I32 this_len = av_len((AV *) this);
+ const I32 this_len = av_len((AV *) This);
I32 i;
for(i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch((AV *)this, i, FALSE);
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
if (svp && matcher_matches_sv(matcher, *svp)) {
destroy_matcher(matcher);
RETPUSHYES;
destroy_matcher(matcher);
RETPUSHNO;
}
- else if (SvIOK(other) || SvNOK(other)) {
+ else if (SvIOK(Other) || SvNOK(Other)) {
I32 i;
- for(i = 0; i <= AvFILL((AV *) this); ++i) {
- SV * const * const svp = av_fetch((AV *)this, i, FALSE);
+ for(i = 0; i <= AvFILL((AV *) This); ++i) {
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
if (!svp)
continue;
- PUSHs(other);
+ PUSHs(Other);
PUSHs(*svp);
PUTBACK;
if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
}
RETPUSHNO;
}
- else if (SvPOK(other)) {
- const I32 this_len = av_len((AV *) this);
+ else if (SvPOK(Other)) {
+ const I32 this_len = av_len((AV *) This);
I32 i;
for(i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch((AV *)this, i, FALSE);
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
if (!svp)
continue;
- PUSHs(other);
+ PUSHs(Other);
PUSHs(*svp);
PUTBACK;
(void) pp_seq();
PMOP * const matcher = make_matcher(this_regex);
PUTBACK;
- PUSHs(matcher_matches_sv(matcher, other)
+ PUSHs(matcher_matches_sv(matcher, Other)
? &PL_sv_yes
: &PL_sv_no);
destroy_matcher(matcher);
SAVETMPS;
PUSHMARK(SP);
PUTBACK;
- c = call_sv(this, G_SCALAR);
+ c = call_sv(This, G_SCALAR);
SPAGAIN;
if (c == 0)
PUSHs(&PL_sv_undef);
else if (SvTEMP(TOPs))
- SvREFCNT_inc(TOPs);
+ SvREFCNT_inc_void(TOPs);
if (SM_OTHER_REF(PVCV)) {
/* This one has to be null-proto'd too.
Call both of 'em, and compare the results */
PUSHMARK(SP);
- c = call_sv(SvRV(other), G_SCALAR);
+ c = call_sv(SvRV(Other), G_SCALAR);
SPAGAIN;
if (c == 0)
PUSHs(&PL_sv_undef);
else if (SvTEMP(TOPs))
- SvREFCNT_inc(TOPs);
+ SvREFCNT_inc_void(TOPs);
FREETMPS;
LEAVE;
PUTBACK;
LEAVE;
RETURN;
}
- else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
- || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
+ else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
+ || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
{
- if (SvPOK(other) && !looks_like_number(other)) {
+ if (SvPOK(Other) && !looks_like_number(Other)) {
/* String comparison */
PUSHs(d); PUSHs(e);
PUTBACK;
PL_curcop = cx->blk_oldcop;
if (CxFOREACH(cx))
- return cx->blk_loop.next_op;
+ return CX_LOOP_NEXTOP_GET(cx);
else
return cx->blk_givwhen.leave_op;
}
dVAR;
SV * const datasv = FILTER_DATA(idx);
const int filter_has_file = IoLINES(datasv);
- GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
SV * const filter_state = (SV *)IoTOP_GV(datasv);
SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
- int len = 0;
+ int status = 0;
+ SV *upstream;
+ STRLEN got_len;
+ const char *got_p = NULL;
+ const char *prune_from = NULL;
+ bool read_from_cache = FALSE;
+ STRLEN umaxlen;
+
+ assert(maxlen >= 0);
+ umaxlen = maxlen;
/* I was having segfault trouble under Linux 2.2.5 after a
parse error occured. (Had to hack around it with a test
- for PL_error_count == 0.) Solaris doesn't segfault --
+ for PL_parser->error_count == 0.) Solaris doesn't segfault --
not sure where the trouble is yet. XXX */
+ if (IoFMT_GV(datasv)) {
+ SV *const cache = (SV *)IoFMT_GV(datasv);
+ if (SvOK(cache)) {
+ STRLEN cache_len;
+ const char *cache_p = SvPV(cache, cache_len);
+ STRLEN take = 0;
+
+ if (umaxlen) {
+ /* Running in block mode and we have some cached data already.
+ */
+ if (cache_len >= umaxlen) {
+ /* In fact, so much data we don't even need to call
+ filter_read. */
+ take = umaxlen;
+ }
+ } else {
+ const char *const first_nl =
+ (const char *)memchr(cache_p, '\n', cache_len);
+ if (first_nl) {
+ take = first_nl + 1 - cache_p;
+ }
+ }
+ if (take) {
+ sv_catpvn(buf_sv, cache_p, take);
+ sv_chop(cache, cache_p + take);
+ /* Definately not EOF */
+ return 1;
+ }
+
+ sv_catsv(buf_sv, cache);
+ if (umaxlen) {
+ umaxlen -= cache_len;
+ }
+ SvOK_off(cache);
+ read_from_cache = TRUE;
+ }
+ }
+
+ /* Filter API says that the filter appends to the contents of the buffer.
+ Usually the buffer is "", so the details don't matter. But if it's not,
+ then clearly what it contains is already filtered by this filter, so we
+ don't want to pass it in a second time.
+ I'm going to use a mortal in case the upstream filter croaks. */
+ upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
+ ? sv_newmortal() : buf_sv;
+ SvUPGRADE(upstream, SVt_PV);
+
if (filter_has_file) {
- len = FILTER_READ(idx+1, buf_sv, maxlen);
+ status = FILTER_READ(idx+1, upstream, 0);
}
- if (filter_sub && len >= 0) {
+ if (filter_sub && status >= 0) {
dSP;
int count;
SAVETMPS;
EXTEND(SP, 2);
- DEFSV = buf_sv;
+ DEFSV = upstream;
PUSHMARK(SP);
- PUSHs(sv_2mortal(newSViv(maxlen)));
+ PUSHs(sv_2mortal(newSViv(0)));
if (filter_state) {
PUSHs(filter_state);
}
if (count > 0) {
SV *out = POPs;
if (SvOK(out)) {
- len = SvIV(out);
+ status = SvIV(out);
}
}
LEAVE;
}
- if (len <= 0) {
- IoLINES(datasv) = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- IoFMT_GV(datasv) = NULL;
+ if(SvOK(upstream)) {
+ got_p = SvPV(upstream, got_len);
+ if (umaxlen) {
+ if (got_len > umaxlen) {
+ prune_from = got_p + umaxlen;
+ }
+ } else {
+ const char *const first_nl =
+ (const char *)memchr(got_p, '\n', got_len);
+ if (first_nl && first_nl + 1 < got_p + got_len) {
+ /* There's a second line here... */
+ prune_from = first_nl + 1;
+ }
}
+ }
+ if (prune_from) {
+ /* Oh. Too long. Stuff some in our cache. */
+ STRLEN cached_len = got_p + got_len - prune_from;
+ SV *cache = (SV *)IoFMT_GV(datasv);
+
+ if (!cache) {
+ IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
+ } else if (SvOK(cache)) {
+ /* Cache should be empty. */
+ assert(!SvCUR(cache));
+ }
+
+ sv_setpvn(cache, prune_from, cached_len);
+ /* If you ask for block mode, you may well split UTF-8 characters.
+ "If it breaks, you get to keep both parts"
+ (Your code is broken if you don't put them back together again
+ before something notices.) */
+ if (SvUTF8(upstream)) {
+ SvUTF8_on(cache);
+ }
+ SvCUR_set(upstream, got_len - cached_len);
+ /* Can't yet be EOF */
+ if (status == 0)
+ status = 1;
+ }
+
+ /* If they are at EOF but buf_sv has something in it, then they may never
+ have touched the SV upstream, so it may be undefined. If we naively
+ concatenate it then we get a warning about use of uninitialised value.
+ */
+ if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+ sv_catsv(buf_sv, upstream);
+ }
+
+ if (status <= 0) {
+ IoLINES(datasv) = 0;
+ SvREFCNT_dec(IoFMT_GV(datasv));
if (filter_state) {
SvREFCNT_dec(filter_state);
IoTOP_GV(datasv) = NULL;
}
filter_del(S_run_user_filter);
}
-
- return len;
+ if (status == 0 && read_from_cache) {
+ /* If we read some data from the cache (and by getting here it implies
+ that we emptied the cache) then we aren't yet at EOF, and mustn't
+ report that to our caller. */
+ return 1;
+ }
+ return status;
}
/* perhaps someone can come up with a better name for
https://perl5.git.perl.org / perl5.git / blobdiff