RETURN;
}
#endif
+
+#define tryAMAGICregexp(rx) \
+ STMT_START { \
+ if (SvROK(rx) && SvAMAGIC(rx)) { \
+ SV *sv = AMG_CALLun(rx, regexp); \
+ if (sv) { \
+ if (SvROK(sv)) \
+ sv = SvRV(sv); \
+ if (SvTYPE(sv) != SVt_REGEXP) \
+ Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
+ rx = sv; \
+ } \
+ } \
+ } STMT_END
+
+
if (PL_op->op_flags & OPf_STACKED) {
/* multiple args; concatentate them */
dMARK; dORIGMARK;
tmpstr = PAD_SV(ARGTARG);
sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
+ SV *msv = *MARK;
if (PL_amagic_generation) {
SV *sv;
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
- (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
+
+ tryAMAGICregexp(msv);
+
+ if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
+ (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
{
sv_setsv(tmpstr, sv);
continue;
}
}
- sv_catsv(tmpstr, *MARK);
+ sv_catsv(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
}
- else
+ else {
tmpstr = POPs;
+ tryAMAGICregexp(tmpstr);
+ }
+
+#undef tryAMAGICregexp
if (SvROK(tmpstr)) {
SV * const sv = SvRV(tmpstr);
if (SvTYPE(sv) == SVt_REGEXP)
re = (REGEXP*) sv;
}
+ else if (SvTYPE(tmpstr) == SVt_REGEXP)
+ re = (REGEXP*) tmpstr;
+
if (re) {
- re = reg_temp_copy(re);
+ re = reg_temp_copy(NULL, re);
ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, re);
}
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
cx->sb_rxtainted |= 2;
sv_catsv(dstr, POPs);
+ /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
+ s -= RX_GOFS(rx);
/* Are we done */
- if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
- s == m, cx->sb_targ, NULL,
- ((cx->sb_rflags & REXEC_COPY_STR)
- ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
- : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+ 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))))
{
SV * const targ = cx->sb_targ;
sv = *++MARK;
else {
sv = &PL_sv_no;
- if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
}
break;
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
lines += FmLINES(PL_formtarget);
- if (lines == 200) {
- arg = t - linemark;
- if (strnEQ(linemark, linemark - arg, arg))
- DIE(aTHX_ "Runaway format");
- }
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) = lines;
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
if (CxTYPE(cx) == CXt_NULL)
return -1;
break;
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
if ((CxTYPE(cx)) == CXt_NULL)
return -1;
break;
++PL_parser->error_count;
}
-OP *
-Perl_die_where(pTHX_ const char *message, STRLEN msglen)
+void
+Perl_die_where(pTHX_ SV *msv)
{
dVAR;
I32 cxix;
I32 gimme;
- if (message) {
+ if (msv) {
if (PL_in_eval & EVAL_KEEPERR) {
static const char prefix[] = "\t(in cleanup) ";
SV * const err = ERRSV;
const char *e = NULL;
if (!SvPOK(err))
sv_setpvs(err,"");
- else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
+ else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
STRLEN len;
+ STRLEN msglen;
+ const char* message = SvPV_const(msv, msglen);
e = SvPV_const(err, len);
e += len - msglen;
if (*e != *message || strNE(e,message))
e = NULL;
}
if (!e) {
- SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
+ STRLEN start;
+ SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catpvn(err, message, msglen);
- if (ckWARN(WARN_MISC)) {
- const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
- Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
- SvPVX_const(err)+start);
- }
+ sv_catsv(err, msv);
+ start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
+ SvPVX_const(err)+start);
}
}
else {
+ STRLEN msglen;
+ const char* message = SvPV_const(msv, msglen);
sv_setpvn(ERRSV, message, msglen);
+ SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
}
}
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
- if (!message)
- message = SvPVx_const(ERRSV, msglen);
+ STRLEN msglen;
+ const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
*msg ? msg : "Unknown error\n");
}
assert(CxTYPE(cx) == CXt_EVAL);
- return cx->blk_eval.retop;
+ PL_restartop = cx->blk_eval.retop;
+ JMPENV_JUMP(3);
+ /* NOTREACHED */
}
}
- if (!message)
- message = SvPVx_const(ERRSV, msglen);
- write_to_stderr(message, msglen);
+ write_to_stderr( msv ? msv : ERRSV );
my_failure_exit();
/* NOTREACHED */
- return 0;
}
PP(pp_xor)
/* 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);
+ tryname = SvPV_nolen_const(*svp);
if (count > 0) {
int i = 0;
SAVEHINTS();
PL_hints = 0;
- if (PL_compiling.cop_hints_hash) {
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
- PL_compiling.cop_hints_hash = NULL;
- }
+ hv_clear(GvHV(PL_hintgv));
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_STD ;
if (filter_sub || filter_cache) {
- SV * const datasv = filter_add(S_run_user_filter, NULL);
+ /* We can use the SvPV of the filter PVIO itself as our cache, rather
+ than hanging another SV from it. In turn, filter_add() optionally
+ takes the SV to use as the filter (or creates a new SV if passed
+ NULL), so simply pass in whatever value filter_cache has. */
+ SV * const datasv = filter_add(S_run_user_filter, filter_cache);
IoLINES(datasv) = filter_has_file;
IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
- IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
}
/* switch to eval mode */
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 = MUTABLE_SV(IoFMT_GV(datasv));
+ {
+ SV *const cache = datasv;
if (SvOK(cache)) {
STRLEN cache_len;
const char *cache_p = SvPV(cache, cache_len);
if (prune_from) {
/* Oh. Too long. Stuff some in our cache. */
STRLEN cached_len = got_p + got_len - prune_from;
- SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
+ SV *const cache = datasv;
- if (!cache) {
- IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
- } else if (SvOK(cache)) {
+ if (SvOK(cache)) {
/* Cache should be empty. */
assert(!SvCUR(cache));
}
if (status <= 0) {
IoLINES(datasv) = 0;
- SvREFCNT_dec(IoFMT_GV(datasv));
if (filter_state) {
SvREFCNT_dec(filter_state);
IoTOP_GV(datasv) = NULL;