#define PERL_IN_PP_HOT_C
#include "perl.h"
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-
/* Hot code. */
#ifdef USE_THREADS
sv_setpvn(TARG,s,len);
if (SvUTF8(TOPs) && !IN_BYTE)
SvUTF8_on(TARG);
+ else
+ SvUTF8_off(TARG);
SETTARG;
RETURN;
}
djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
- STRLEN len;
- char *s;
- bool left_utf = DO_UTF8(left);
- bool right_utf = DO_UTF8(right);
+ SV* rcopy = Nullsv;
- if (TARG != left) {
- if (right_utf && !left_utf)
- sv_utf8_upgrade(left);
- s = SvPV(left,len);
- SvUTF8_off(TARG);
- if (TARG == right) {
- if (left_utf && !right_utf)
- sv_utf8_upgrade(right);
- sv_insert(TARG, 0, 0, s, len);
- if (left_utf || right_utf)
- SvUTF8_on(TARG);
- SETs(TARG);
- RETURN;
+ if (SvGMAGICAL(left))
+ mg_get(left);
+ if (TARG == right && SvGMAGICAL(right))
+ mg_get(right);
+
+ if (TARG == right && left != right)
+ /* Clone since otherwise we cannot prepend. */
+ rcopy = sv_2mortal(newSVsv(right));
+
+ if (TARG != left)
+ sv_setsv(TARG, left);
+
+ if (TARG == right) {
+ if (left == right) {
+ /* $right = $right . $right; */
+ STRLEN rlen;
+ char *rpv = SvPV(right, rlen);
+
+ sv_catpvn(TARG, rpv, rlen);
}
- sv_setpvn(TARG,s,len);
- }
- else if (SvGMAGICAL(TARG)) {
- mg_get(TARG);
- if (right_utf && !left_utf)
- sv_utf8_upgrade(left);
+ else /* $right = $left . $right; */
+ sv_catsv(TARG, rcopy);
}
- else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
- sv_setpv(TARG, ""); /* Suppress warning. */
- s = SvPV_force(TARG, len);
+ else {
+ if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
+ sv_setpv(TARG, "");
+ /* $other = $left . $right; */
+ /* $left = $left . $right; */
+ sv_catsv(TARG, right);
}
- if (left_utf && !right_utf)
- sv_utf8_upgrade(right);
- s = SvPV(right,len);
- if (SvOK(TARG)) {
+
#if defined(PERL_Y2KWARN)
- if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
- STRLEN n;
- char *s = SvPV(TARG,n);
- if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
- && (n == 2 || !isDIGIT(s[n-3])))
- {
- Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
- "about to append an integer to '19'");
- }
+ if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
+ STRLEN n;
+ char *s = SvPV(TARG,n);
+ if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
+ && (n == 2 || !isDIGIT(s[n-3])))
+ {
+ Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
+ "about to append an integer to '19'");
}
-#endif
- sv_catpvn(TARG,s,len);
}
- else
- sv_setpvn(TARG,s,len); /* suppress warning */
- if (left_utf || right_utf)
- SvUTF8_on(TARG);
+#endif
+
SETTARG;
RETURN;
}
else
gv = PL_defoutgv;
if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
+ had_magic:
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
* pass object as 1st arg, so move other args up ...
RETURN;
}
if (!(io = GvIO(gv))) {
- if (ckWARN(WARN_UNOPENED)) {
- SV* sv = sv_newmortal();
- gv_efullname3(sv, gv, Nullch);
- Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened",
- SvPV(sv,n_a));
- }
+ dTHR;
+ if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
+ goto had_magic;
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED, WARN_IO)) {
if (IoIFP(io)) {
- SV* sv = sv_newmortal();
- gv_efullname3(sv, gv, Nullch);
- Perl_warner(aTHX_ WARN_IO,
- "Filehandle %s opened only for input",
- SvPV(sv,n_a));
+ /* integrate with report_evil_fh()? */
+ char *name = NULL;
+ if (isGV(gv)) {
+ SV* sv = sv_newmortal();
+ gv_efullname4(sv, gv, Nullch, FALSE);
+ name = SvPV_nolen(sv);
+ }
+ if (name && *name)
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle %s opened only for input", name);
+ else
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle opened only for input");
}
- else if (ckWARN(WARN_CLOSED))
- report_closed_fh(gv, io, "print", "filehandle");
+ else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
s = SvPV(TARG, len);
strend = s + len;
if (!s)
- DIE(aTHX_ "panic: do_match");
+ DIE(aTHX_ "panic: pp_match");
rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
if (update_minmatch++)
minmatch = had_zerolen;
}
- if (rx->reganch & RE_USE_INTUIT) {
+ if (rx->reganch & RE_USE_INTUIT &&
+ DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
}
else {
PerlIO_rewind(tmpfp);
- IoTYPE(io) = '<';
+ IoTYPE(io) = IoTYPE_RDONLY;
IoIFP(io) = fp = tmpfp;
IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
}
else if (type == OP_GLOB)
SP--;
else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
- && (IoTYPE(io) == '>' || fp == PerlIO_stdout()
+ && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
|| fp == PerlIO_stderr()))
{
- SV* sv = sv_newmortal();
- gv_efullname3(sv, PL_last_in_gv, Nullch);
- Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
- SvPV_nolen(sv));
+ /* integrate with report_evil_fh()? */
+ char *name = NULL;
+ if (isGV(PL_last_in_gv)) { /* can this ever fail? */
+ SV* sv = sv_newmortal();
+ gv_efullname4(sv, PL_last_in_gv, Nullch, FALSE);
+ name = SvPV_nolen(sv);
+ }
+ if (name && *name)
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle %s opened only for output", name);
+ else
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle opened only for output");
}
}
if (!fp) {
- if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
+ if (ckWARN2(WARN_GLOB, WARN_CLOSED)
+ && (!io || !(IoFLAGS(io) & IOf_START))) {
if (type == OP_GLOB)
Perl_warner(aTHX_ WARN_GLOB,
"glob failed (can't start child: %s)",
Strerror(errno));
else
- report_closed_fh(PL_last_in_gv, io, "readline", "filehandle");
+ report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
}
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
offset = 0;
}
+ /* This should not be marked tainted if the fp is marked clean */
+#define MAYBE_TAINT_LINE(io, sv) \
+ if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
+ TAINT; \
+ SvTAINTED_on(sv); \
+ }
+
/* delay EOF state for a snarfed empty file */
#define SNARF_EOF(gimme,rs,io,sv) \
(gimme != G_SCALAR || SvCUR(sv) \
(void)SvOK_off(TARG);
PUSHTARG;
}
+ MAYBE_TAINT_LINE(io, sv);
RETURN;
}
- /* This should not be marked tainted if the fp is marked clean */
- if (!(IoFLAGS(io) & IOf_UNTAINT)) {
- TAINT;
- SvTAINTED_on(sv);
- }
+ MAYBE_TAINT_LINE(io, sv);
IoLINES(io)++;
IoFLAGS(io) |= IOf_NOLINE;
SvSETMAGIC(sv);
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
+ bool do_utf8;
+ STRLEN slen;
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
else {
TARG = DEFSV;
EXTEND(SP,1);
- }
+ }
+ do_utf8 = DO_UTF8(TARG);
+ if (SvFAKE(TARG) && SvREADONLY(TARG))
+ sv_force_normal(TARG);
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
force_it:
if (!pm || !s)
- DIE(aTHX_ "panic: do_subst");
+ DIE(aTHX_ "panic: pp_subst");
strend = s + len;
- maxiters = 2*(strend - s) + 10; /* We can match twice at each
- position, once with zero-length,
- second time with non-zero. */
+ slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
+ maxiters = 2 * slen + 10; /* We can match twice at each
+ position, once with zero-length,
+ second time with non-zero. */
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
{
+ bool isutf8;
+
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
SvPVX(TARG) = SvPVX(dstr);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
+ isutf8 = DO_UTF8(dstr);
SvPVX(dstr) = 0;
sv_free(dstr);
PUSHs(sv_2mortal(newSViv((I32)iters)));
(void)SvPOK_only(TARG);
+ if (isutf8)
+ SvUTF8_on(TARG);
TAINT_IF(rxtainted);
SvSETMAGIC(TARG);
SvTAINT(TARG);
{
djSP;
SV** svp;
- I32 elem = POPi;
+ IV elem = POPi;
AV* av = (AV*)POPs;
U32 lval = PL_op->op_flags & OPf_MOD;
U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
name = SvPV(meth, namelen);
sv = *(PL_stack_base + TOPMARK + 1);
+ if (!sv)
+ Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
+
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvROK(sv))
https://perl5.git.perl.org / perl5.git / blobdiff