/* pp_ctl.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 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.
memNE(PM_GETRE(pm)->precomp, t, len))
{
if (PM_GETRE(pm)) {
- ReREFCNT_dec(PM_GETRE(pm));
+ ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
+ SV *nsv = Nullsv;
+
+ {
+ REGEXP *old = PM_GETRE(pm);
+ if(old != rx) {
+ if(old)
+ ReREFCNT_dec(old);
+ PM_SETRE(pm,rx);
+ }
+ }
rxres_restore(&cx->sb_rxres, rx);
RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
{
SV *targ = cx->sb_targ;
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ if (DO_UTF8(dstr) && !SvUTF8(targ))
+ sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+ else
+ sv_catpvn(dstr, s, cx->sb_strend - s);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
- (void)SvOOK_off(targ);
- if (SvLEN(targ))
- Safefree(SvPVX(targ));
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(targ)) {
+ sv_force_normal_flags(targ, SV_COW_DROP_PV);
+ } else
+#endif
+ {
+ (void)SvOOK_off(targ);
+ if (SvLEN(targ))
+ Safefree(SvPVX(targ));
+ }
SvPVX(targ) = SvPVX(dstr);
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
- PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
+ PUSHs(sv_2mortal(newSViv(saviters - 1)));
(void)SvPOK_only_UTF8(targ);
TAINT_IF(cx->sb_rxtainted);
SvTAINT(targ);
LEAVE_SCOPE(cx->sb_oldsave);
+ ReREFCNT_dec(rx);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
cx->sb_strend = s + (cx->sb_strend - m);
}
cx->sb_m = m = rx->startp[0] + orig;
- if (m > s)
- sv_catpvn(dstr, s, m-s);
+ 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;
{ /* Update the pos() information. */
SV *sv = cx->sb_targ;
sv_pos_b2u(sv, &i);
mg->mg_len = i;
}
+ ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
U32 i;
if (!p || p[1] < rx->nparens) {
+#ifdef PERL_COPY_ON_WRITE
+ i = 7 + rx->nparens * 2;
+#else
i = 6 + rx->nparens * 2;
+#endif
if (!p)
New(501, p, i, UV);
else
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
RX_MATCH_COPIED_off(rx);
+#ifdef PERL_COPY_ON_WRITE
+ *p++ = PTR2UV(rx->saved_copy);
+ rx->saved_copy = Nullsv;
+#endif
+
*p++ = rx->nparens;
*p++ = PTR2UV(rx->subbeg);
UV *p = (UV*)*rsp;
U32 i;
- if (RX_MATCH_COPIED(rx))
- Safefree(rx->subbeg);
+ RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
+#ifdef PERL_COPY_ON_WRITE
+ if (rx->saved_copy)
+ SvREFCNT_dec (rx->saved_copy);
+ rx->saved_copy = INT2PTR(SV*,*p);
+ *p++ = 0;
+#endif
+
rx->nparens = *p++;
rx->subbeg = INT2PTR(char*,*p++);
if (p) {
Safefree(INT2PTR(char*,*p));
+#ifdef PERL_COPY_ON_WRITE
+ if (p[1]) {
+ SvREFCNT_dec (INT2PTR(SV*,p[1]));
+ }
+#endif
Safefree(p);
*rsp = Null(void*);
}
bool gotsome = FALSE;
STRLEN len;
STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
- bool item_is_utf = FALSE;
+ bool item_is_utf8 = FALSE;
+ bool targ_is_utf8 = FALSE;
+ SV * nsv = Nullsv;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
if (SvREADONLY(tmpForm)) {
else
doparseform(tmpForm);
}
-
SvPV_force(PL_formtarget, len);
+ if (DO_UTF8(PL_formtarget))
+ targ_is_utf8 = TRUE;
t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
t += len;
f = SvPV(tmpForm, len);
case FF_LITERAL:
arg = *fpc++;
+ if (targ_is_utf8 && !SvUTF8(tmpForm)) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
+ t = SvEND(PL_formtarget);
+ break;
+ }
+ if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_utf8_upgrade(PL_formtarget);
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ t = SvEND(PL_formtarget);
+ targ_is_utf8 = TRUE;
+ }
while (arg--)
*t++ = *f++;
break;
break;
s++;
}
- item_is_utf = TRUE;
+ item_is_utf8 = TRUE;
itemsize = s - item;
sv_pos_b2u(sv, &itemsize);
break;
}
}
- item_is_utf = FALSE;
+ item_is_utf8 = FALSE;
if (itemsize > fieldsize)
itemsize = fieldsize;
send = chophere = s + itemsize;
itemsize = chophere - item;
sv_pos_b2u(sv, &itemsize);
}
- item_is_utf = TRUE;
+ item_is_utf8 = TRUE;
break;
}
}
- item_is_utf = FALSE;
+ item_is_utf8 = FALSE;
if (itemsize <= fieldsize) {
send = chophere = s + itemsize;
while (s < send) {
case FF_ITEM:
arg = itemsize;
s = item;
- if (item_is_utf) {
+ if (item_is_utf8) {
+ if (!targ_is_utf8) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_utf8_upgrade(PL_formtarget);
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ t = SvEND(PL_formtarget);
+ targ_is_utf8 = TRUE;
+ }
while (arg--) {
if (UTF8_IS_CONTINUED(*s)) {
STRLEN skip = UTF8SKIP(s);
}
break;
}
+ if (targ_is_utf8 && !item_is_utf8) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
+ for (; t < SvEND(PL_formtarget); t++) {
+#ifdef EBCDIC
+ int ch = *t++ = *s++;
+ if (iscntrl(ch))
+#else
+ if (!(*t & ~31))
+#endif
+ *t = ' ';
+ }
+ break;
+ }
while (arg--) {
#ifdef EBCDIC
int ch = *t++ = *s++;
case FF_LINEGLOB:
item = s = SvPV(sv, len);
itemsize = len;
- item_is_utf = FALSE; /* XXX is this correct? */
+ if ((item_is_utf8 = DO_UTF8(sv)))
+ itemsize = sv_len_utf8(sv);
if (itemsize) {
+ bool chopped = FALSE;
gotsome = TRUE;
- send = s + itemsize;
+ send = s + len;
while (s < send) {
if (*s++ == '\n') {
- if (s == send)
+ if (s == send) {
itemsize--;
+ chopped = TRUE;
+ }
else
lines++;
}
}
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- sv_catpvn(PL_formtarget, item, itemsize);
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
+ sv_catsv(PL_formtarget, sv);
+ if (chopped)
+ SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+ if (item_is_utf8)
+ targ_is_utf8 = TRUE;
}
break;
if (strnEQ(linemark, linemark - arg, arg))
DIE(aTHX_ "Runaway format");
}
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) = lines;
SP = ORIGMARK;
RETURNOP(cLISTOP->op_first);
case FF_END:
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
SP = ORIGMARK;
RETPUSHYES;
sv_setpvn(ERRSV, message, msglen);
}
}
- else
- message = SvPVx(ERRSV, msglen);
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
+ if (!message)
+ message = SvPVx(ERRSV, msglen);
PerlIO_write(Perl_error_log, "panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
else if (old_warnings == pWARN_ALL ||
- (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
- mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+ (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
+ /* Get the bit mask for $warnings::Bits{all}, because
+ * it could have been extended by warnings::register */
+ SV **bits_all;
+ HV *bits = get_hv("warnings::Bits", FALSE);
+ if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
+ mask = newSVsv(*bits_all);
+ }
+ else {
+ mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+ }
+ }
else
mask = newSVsv(old_warnings);
PUSHs(sv_2mortal(mask));
}
PL_stack_sp = newsp;
+ LEAVE;
/* Stack values are safe: */
if (popsub2) {
POPSUB(cx,sv); /* release CV and @_ ... */
sv = Nullsv;
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
LEAVESUB(sv);
if (clear_errsv)
sv_setpv(ERRSV,"");
SP = newsp;
PUTBACK;
+ LEAVE;
/* Stack values are safe: */
switch (pop2) {
case CXt_LOOP:
}
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
LEAVESUB(sv);
return nextop;
}
}
/* First do some returnish stuff. */
+ SvREFCNT_inc(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
AvFLAGS(av) = AVf_REIFY;
PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
}
+ else
+ CLEAR_ARGARRAY(av);
}
else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
AV* av;
/* Now do some callish stuff. */
SAVETMPS;
+ SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
if (CvOLDSTYLE(cv)) {
switch (CxTYPE(cx)) {
case CXt_EVAL:
leaving_eval = TRUE;
- if (CxREALEVAL(cx)) {
+ if (!CxTRYBLOCK(cx)) {
gotoprobe = (last_eval_cx ?
last_eval_cx->blk_eval.old_eval_root :
PL_eval_root);
}
STATIC PerlIO *
-S_doopen_pmc(pTHX_ const char *name, const char *mode)
+S_doopen_pm(pTHX_ const char *name, const char *mode)
{
+#ifndef PERL_DISABLE_PMC
STRLEN namelen = strlen(name);
PerlIO *fp;
fp = PerlIO_open(name, mode);
}
return fp;
+#else
+ return PerlIO_open(name, mode);
+#endif /* !PERL_DISABLE_PMC */
}
PP(pp_require)
if (path_is_absolute(name)) {
tryname = name;
- tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
}
#ifdef MACOS_TRADITIONAL
if (!tryrsfp) {
MacPerl_CanonDir(name, newname, 1);
if (path_is_absolute(newname)) {
tryname = newname;
- tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
}
}
#endif
#endif
TAINT_PROPER("require");
tryname = SvPVX(namesv);
- tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/')
tryname += 2;
U16 *linepc = 0;
register I32 arg;
bool ischop;
+ int maxops = 2; /* FF_LINEMARK + FF_END) */
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
- New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
+ /* estimate the buffer size needed */
+ for (base = s; s <= send; s++) {
+ if (*s == '\n' || *s == '@' || *s == '^')
+ maxops += 10;
+ }
+ s = base;
+ base = Nullch;
+
+ New(804, fops, maxops, U16);
fpc = fops;
if (s < send) {
}
*fpc++ = FF_END;
+ assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
arg = fpc - fops;
{ /* need to jump to the next word */
int z;