#define PERL_IN_PP_HOT_C
#include "perl.h"
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-
/* Hot code. */
#ifdef USE_THREADS
dPOPTOPssrl;
STRLEN len;
U8 *s;
- bool left_utf;
- bool right_utf;
+ bool left_utf8;
+ bool right_utf8;
if (TARG == right && SvGMAGICAL(right))
mg_get(right);
if (SvGMAGICAL(left))
mg_get(left);
- left_utf = DO_UTF8(left);
- right_utf = DO_UTF8(right);
-
- if (left_utf != right_utf) {
- if (TARG == right && !right_utf) {
+ left_utf8 = DO_UTF8(left);
+ right_utf8 = DO_UTF8(right);
+
+ if (left_utf8 != right_utf8) {
+ if (TARG == right && !right_utf8) {
sv_utf8_upgrade(TARG); /* Now straight binary copy */
SvUTF8_on(TARG);
}
U8 *l, *c, *olds = NULL;
STRLEN targlen;
s = (U8*)SvPV(right,len);
- right_utf |= DO_UTF8(right);
+ right_utf8 |= DO_UTF8(right);
if (TARG == right) {
/* Take a copy since we're about to overwrite TARG */
olds = s = (U8*)savepvn((char*)s, len);
}
- if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG)
- sv_setpv(left, ""); /* Suppress warning. */
+ if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
+ if (SvREADONLY(left))
+ left = sv_2mortal(newSVsv(left));
+ else
+ sv_setpv(left, ""); /* Suppress warning. */
+ }
l = (U8*)SvPV(left, targlen);
- left_utf |= DO_UTF8(left);
+ left_utf8 |= DO_UTF8(left);
if (TARG != left)
sv_setpvn(TARG, (char*)l, targlen);
- if (!left_utf)
+ if (!left_utf8)
sv_utf8_upgrade(TARG);
/* Extend TARG to length of right (s) */
targlen = SvCUR(TARG) + len;
- if (!right_utf) {
+ if (!right_utf8) {
/* plus one for each hi-byte char if we have to upgrade */
for (c = s; c < s + len; c++) {
- if (*c & 0x80)
+ if (UTF8_IS_CONTINUED(*c))
targlen++;
}
}
SvGROW(TARG, targlen+1);
/* And now copy, maybe upgrading right to UTF8 on the fly */
- for (c = (U8*)SvEND(TARG); len--; s++) {
- if (*s & 0x80 && !right_utf)
- c = uv_to_utf8(c, *s);
- else
- *c++ = *s;
- }
+ if (right_utf8)
+ Copy(s, SvEND(TARG), len, U8);
+ else {
+ for (c = (U8*)SvEND(TARG); len--; s++)
+ c = uv_to_utf8(c, *s);
+ }
SvCUR_set(TARG, targlen);
*SvEND(TARG) = '\0';
SvUTF8_on(TARG);
}
else
sv_setpvn(TARG, (char *)s, len); /* suppress warning */
- if (left_utf)
+ if (left_utf8)
SvUTF8_on(TARG);
SETTARG;
RETURN;
RETURN;
}
if (!(io = GvIO(gv))) {
- dTHR;
if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED, WARN_IO)) {
- if (IoIFP(io)) {
- /* 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");
- }
+ if (IoIFP(io))
+ report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
}
else {
MARK++;
- if (PL_ofslen) {
+ if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
while (MARK <= SP) {
if (!do_print(*MARK, fp))
break;
MARK++;
if (MARK <= SP) {
- if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
+ if (!do_print(PL_ofs_sv, fp)) { /* $, */
MARK--;
break;
}
if (MARK <= SP)
goto just_say_no;
else {
- if (PL_orslen)
- if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
+ if (PL_ors_sv && SvOK(PL_ors_sv))
+ if (!do_print(PL_ors_sv, fp)) /* $\ */
goto just_say_no;
if (IoFLAGS(io) & IOf_FLUSH)
else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
&& (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
|| fp == PerlIO_stderr()))
- {
- /* 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");
- }
+ report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
}
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)",
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);
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+ I32 preeminent;
if (SvTYPE(hv) == SVt_PVHV) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : 0;
}
if (PL_op->op_private & OPpLVAL_INTRO) {
if (HvNAME(hv) && isGV(*svp))
save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
- else
- save_helem(hv, keysv, svp);
+ else {
+ if (!preeminent) {
+ STRLEN keylen;
+ char *key = SvPV(keysv, keylen);
+ save_delete(hv, key, keylen);
+ } else
+ save_helem(hv, keysv, svp);
+ }
}
else if (PL_op->op_private & OPpDEREF)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
STATIC CV *
S_get_db_sub(pTHX_ SV **svp, CV *cv)
{
- dTHR;
SV *dbsv = GvSV(PL_DBsub);
if (!PERLDB_SUB_NN) {
unset_cvowner(pTHXo_ void *cvarg)
{
register CV* cv = (CV *) cvarg;
-#ifdef DEBUGGING
- dTHR;
-#endif /* DEBUGGING */
DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
projects / p5sagit/p5-mst-13.2.git / blobdiff