{
dVAR;
dSP;
- register PMOP *pm = (PMOP*)cLOGOP->op_other;
+ PMOP *pm = (PMOP*)cLOGOP->op_other;
SV **args;
int nargs;
REGEXP *re = NULL;
{
dVAR;
dSP;
- register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- register PMOP * const pm = (PMOP*) cLOGOP->op_other;
- register SV * const dstr = cx->sb_dstr;
- register char *s = cx->sb_s;
- register char *m = cx->sb_m;
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PMOP * const pm = (PMOP*) cLOGOP->op_other;
+ SV * const dstr = cx->sb_dstr;
+ char *s = cx->sb_s;
+ char *m = cx->sb_m;
char *orig = cx->sb_orig;
- register REGEXP * const rx = cx->sb_rx;
+ REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
(s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
- ((cx->sb_rflags & REXEC_COPY_STR)
- ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
- : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+ (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
{
SV *targ = cx->sb_targ;
SvUTF8_on(targ);
SvPV_set(dstr, NULL);
+ PL_tainted = 0;
mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
+ assert(!RX_SUBOFFSET(rx));
cx->sb_orig = orig = RX_SUBBEG(rx);
s = orig + (m - s);
cx->sb_strend = s + (cx->sb_strend - m);
if (!p || p[1] < RX_NPARENS(rx)) {
#ifdef PERL_OLD_COPY_ON_WRITE
- i = 7 + RX_NPARENS(rx) * 2;
+ i = 7 + (RX_NPARENS(rx)+1) * 2;
#else
- i = 6 + RX_NPARENS(rx) * 2;
+ i = 6 + (RX_NPARENS(rx)+1) * 2;
#endif
if (!p)
Newx(p, i, UV);
*rsp = (void*)p;
}
+ /* what (if anything) to free on croak */
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
RX_MATCH_COPIED_off(rx);
+ *p++ = RX_NPARENS(rx);
#ifdef PERL_OLD_COPY_ON_WRITE
*p++ = PTR2UV(RX_SAVED_COPY(rx));
RX_SAVED_COPY(rx) = NULL;
#endif
- *p++ = RX_NPARENS(rx);
-
*p++ = PTR2UV(RX_SUBBEG(rx));
*p++ = (UV)RX_SUBLEN(rx);
+ *p++ = (UV)RX_SUBOFFSET(rx);
+ *p++ = (UV)RX_SUBCOFFSET(rx);
for (i = 0; i <= RX_NPARENS(rx); ++i) {
*p++ = (UV)RX_OFFS(rx)[i].start;
*p++ = (UV)RX_OFFS(rx)[i].end;
RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
+ RX_NPARENS(rx) = *p++;
#ifdef PERL_OLD_COPY_ON_WRITE
if (RX_SAVED_COPY(rx))
*p++ = 0;
#endif
- RX_NPARENS(rx) = *p++;
-
RX_SUBBEG(rx) = INT2PTR(char*,*p++);
RX_SUBLEN(rx) = (I32)(*p++);
+ RX_SUBOFFSET(rx) = (I32)*p++;
+ RX_SUBCOFFSET(rx) = (I32)*p++;
for (i = 0; i <= RX_NPARENS(rx); ++i) {
RX_OFFS(rx)[i].start = (I32)(*p++);
RX_OFFS(rx)[i].end = (I32)(*p++);
PERL_UNUSED_CONTEXT;
if (p) {
-#ifdef PERL_POISON
void *tmp = INT2PTR(char*,*p);
- Safefree(tmp);
- if (*p)
- PoisonFree(*p, 1, sizeof(*p));
+#ifdef PERL_POISON
+#ifdef PERL_OLD_COPY_ON_WRITE
+ U32 i = 9 + p[1] * 2;
#else
- Safefree(INT2PTR(char*,*p));
+ U32 i = 8 + p[1] * 2;
+#endif
#endif
+
#ifdef PERL_OLD_COPY_ON_WRITE
- if (p[1]) {
- SvREFCNT_dec (INT2PTR(SV*,p[1]));
- }
+ SvREFCNT_dec (INT2PTR(SV*,p[2]));
#endif
+#ifdef PERL_POISON
+ PoisonFree(p, i, sizeof(UV));
+#endif
+
+ Safefree(tmp);
Safefree(p);
*rsp = NULL;
}
PP(pp_formline)
{
dVAR; dSP; dMARK; dORIGMARK;
- register SV * const tmpForm = *++MARK;
+ SV * const tmpForm = *++MARK;
SV *formsv; /* contains text of original format */
- register U32 *fpc; /* format ops program counter */
- register char *t; /* current append position in target string */
+ U32 *fpc; /* format ops program counter */
+ char *t; /* current append position in target string */
const char *f; /* current position in format string */
- register I32 arg;
- register SV *sv = NULL; /* current item */
+ I32 arg;
+ SV *sv = NULL; /* current item */
const char *item = NULL;/* string value of current item */
I32 itemsize = 0; /* length of current item, possibly truncated */
I32 fieldsize = 0; /* width of current field */
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(left,right)) {
- register IV i, j;
+ IV i, j;
IV max;
if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
(SvOK(right) && SvNV_nomg(right) > IV_MAX))
S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
{
dVAR;
- register I32 i;
+ I32 i;
PERL_ARGS_ASSERT_DOPOPTOLABEL;
for (i = cxstack_ix; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstack[i];
+ const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstk[i];
+ const PERL_CONTEXT * const cx = &cxstk[i];
switch (CxTYPE(cx)) {
default:
continue;
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstack[i];
+ const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
while (cxstack_ix > cxix) {
SV *sv;
- register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
if (cxix >= 0) {
I32 optype;
SV *namesv;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV **newsp;
COP *oldcop;
JMPENV *restartjmpenv;
const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- register I32 cxix = dopoptosub(cxstack_ix);
- register const PERL_CONTEXT *cx;
- register const PERL_CONTEXT *ccstack = cxstack;
+ I32 cxix = dopoptosub(cxstack_ix);
+ const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
for (;;) {
{
dVAR;
dSP;
- register const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
I32 gimme;
const HEK *stash_hek;
if (CxTYPE(cx) == CXt_EVAL) {
/* eval STRING */
if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
- PUSHs(cx->blk_eval.cur_text);
+ PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
+ SvCUR(cx->blk_eval.cur_text)-2,
+ SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
PUSHs(&PL_sv_no);
}
/* require */
Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
}
- /* XXX only hints propagated via op_private are currently
- * visible (others are not easily accessible, since they
- * use the global PL_hints) */
mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
- if (old_warnings == pWARN_NONE ||
- (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
+ if (old_warnings == pWARN_NONE)
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+ else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
+ mask = &PL_sv_undef ;
else if (old_warnings == pWARN_ALL ||
(old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
/* Get the bit mask for $warnings::Bits{all}, because
{
dVAR;
dSP;
- const char * const tmps =
- (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
- sv_reset(tmps, CopSTASH(PL_curcop));
+ const char * tmps;
+ STRLEN len = 0;
+ if (MAXARG < 1 || (!TOPs && !POPs))
+ tmps = NULL, len = 0;
+ else
+ tmps = SvPVx_const(POPs, len);
+ sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
}
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = G_ARRAY;
U8 hasargs;
GV * const gv = PL_DBgv;
- register CV * const cv = GvCV(gv);
+ CV * cv = NULL;
+
+ if (gv && isGV_with_GP(gv))
+ cv = GvCV(gv);
- if (!cv)
+ if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
DIE(aTHX_ "No DB::DB routine defined");
if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
SPAGAIN;
if (CvISXSUB(cv)) {
- CvDEPTH(cv)++;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
- CvDEPTH(cv)--;
FREETMPS;
LEAVE;
return NORMAL;
PP(pp_enter)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
ENTER_with_name("block");
PP(pp_leave)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV **newsp;
PMOP *newpm;
I32 gimme;
PP(pp_enteriter)
{
dVAR; dSP; dMARK;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
void *itervar; /* location of the iteration variable */
U8 cxtype = CXt_LOOP_FOR;
PP(pp_enterloop)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
ENTER_with_name("loop1");
PP(pp_leaveloop)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
PP(pp_return)
{
dVAR; dSP; dMARK;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
bool lval = FALSE;
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
if (CxMULTICALL(&cxstack[cxstack_ix]))
PP(pp_last)
{
dVAR;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 pop2 = 0;
I32 gimme;
I32 optype;
PP(pp_next)
{
dVAR;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 inner = PL_scopestack_ix;
S_unwind_loop(aTHX_ "next");
{
dVAR;
const I32 cxix = S_unwind_loop(aTHX_ "redo");
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 oldsave;
OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
dVAR; dSP;
OP *retop = NULL;
I32 ix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
/* This egregious kludge implements goto &subroutine */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
CV *cv = MUTABLE_CV(SvRV(sv));
SV** mark;
I32 items = 0;
return retop;
}
else {
- AV* const padlist = CvPADLIST(cv);
+ PADLIST * const padlist = CvPADLIST(cv);
if (CxTYPE(cx) == CXt_EVAL) {
PL_in_eval = CxOLD_IN_EVAL(cx);
PL_eval_root = cx->blk_eval.old_eval_root;
CV*
Perl_find_runcv(pTHX_ U32 *db_seqp)
{
- return Perl_find_runcv_where(aTHX_ 0, NULL, db_seqp);
+ return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
}
/* If this becomes part of the API, it might need a better name. */
CV *
-Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
+Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
{
dVAR;
PERL_SI *si;
cv = cx->blk_eval.cv;
if (cv) {
switch (cond) {
- case FIND_RUNCV_root_eq:
- if (CvROOT(cv) != (OP *)arg) continue;
+ case FIND_RUNCV_padid_eq:
+ if (!CvPADLIST(cv)
+ || CvPADLIST(cv)->xpadl_id != (U32)arg) continue;
return cv;
case FIND_RUNCV_level_eq:
- if (level++ != PTR2IV(arg)) continue;
+ if (level++ != arg) continue;
/* GERONIMO! */
default:
return cv;
}
}
}
- return cond == FIND_RUNCV_root_eq ? NULL : PL_main_cv;
+ return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
}
PP(pp_require)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
const char *name;
STRLEN len;
}
}
+ LOADING_FILE_PROBE(unixname);
+
/* prepare to compile file */
if (path_is_absolute(name)) {
if (namesv) { /* did we lookup @INC? */
AV * const ar = GvAVn(PL_incgv);
I32 i;
+ SV *const msg = newSVpv("", 0);
SV *const inc = newSVpvs_flags("", SVs_TEMP);
for (i = 0; i <= AvFILL(ar); i++) {
sv_catpvs(inc, " ");
sv_catsv(inc, *av_fetch(ar, i, TRUE));
}
+ if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
+ const char *c, *e = name + len - 3;
+ sv_catpv(msg, " (you may need to install the ");
+ for (c = name; c < e; c++) {
+ if (*c == '/') {
+ sv_catpvn(msg, "::", 2);
+ }
+ else {
+ sv_catpvn(msg, c, 1);
+ }
+ }
+ sv_catpv(msg, " module)");
+ }
+ else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
+ sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
+ }
+ else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
+ sv_catpv(msg, " (did you run h2ph?)");
+ }
/* diag_listed_as: Can't locate %s */
DIE(aTHX_
- "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
- name,
- (len >= 2 && memEQ(name + len - 2, ".h", 3)
- ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
- (len >= 3 && memEQ(name + len - 3, ".ph", 4)
- ? " (did you run h2ph?)" : ""),
- inc
- );
+ "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
+ name, msg, inc);
}
}
DIE(aTHX_ "Can't locate %s", name);
/* Restore encoding. */
PL_encoding = encoding;
+ LOADED_FILE_PROBE(unixname);
+
return op;
}
PP(pp_entereval)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
const I32 gimme = GIMME_V;
const U32 was = PL_breakable_sub_gen;
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
OP *retop;
const U8 save_flags = PL_op -> op_flags;
I32 optype;
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 optype;
PERL_ASYNC_CHECK();
PP(pp_entergiven)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
ENTER_with_name("given");
PP(pp_leavegiven)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
PP(pp_enterwhen)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
/* This is essentially an optimization: if the match
{
dVAR; dSP;
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
{
dVAR; dSP;
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
{
dVAR;
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
cxix = dopoptogiven(cxstack_ix);
if (cxix < 0)
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
- register char *s = SvPV(sv, len);
- register char *send;
- register char *base = NULL; /* start of current field */
- register I32 skipspaces = 0; /* number of contiguous spaces seen */
+ char *s = SvPV(sv, len);
+ char *send;
+ char *base = NULL; /* start of current field */
+ I32 skipspaces = 0; /* number of contiguous spaces seen */
bool noblank = FALSE; /* ~ or ~~ seen on this line */
bool repeat = FALSE; /* ~~ seen on this line */
bool postspace = FALSE; /* a text field may need right padding */
U32 *fops;
- register U32 *fpc;
+ U32 *fpc;
U32 *linepc = NULL; /* position of last FF_LINEMARK */
- register I32 arg;
+ I32 arg;
bool ischop; /* it's a ^ rather than a @ */
bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
https://perl5.git.perl.org / perl5.git / blobdiff