{
dPOPTOPssrl;
STRLEN len;
- char *s;
+ U8 *s;
bool left_utf = DO_UTF8(left);
bool right_utf = DO_UTF8(right);
}
else {
/* Set TARG to PV(left), then add right */
- char *l, *c;
+ U8 *l, *c, *olds = NULL;
STRLEN targlen;
- if (TARG == right)
- /* Need a safe copy elsewhere since we're just about to
- write onto TARG */
- s = strdup(SvPV(right,len));
- else
- s = SvPV(right,len);
- l = SvPV(left, targlen);
+ s = (U8*)SvPV(right,len);
+ if (TARG == right) {
+ /* Take a copy since we're about to overwrite TARG */
+ olds = s = (U8*)savepvn((char*)s, len);
+ }
+ if (SvGMAGICAL(left))
+ mg_get(left);
+ else if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG)
+ sv_setpv(left, ""); /* Suppress warning. */
+ l = (U8*)SvPV(left, targlen);
if (TARG != left)
- sv_setpvn(TARG,l,targlen);
+ sv_setpvn(TARG, (char*)l, targlen);
if (!left_utf)
sv_utf8_upgrade(TARG);
/* Extend TARG to length of right (s) */
targlen = SvCUR(TARG) + len;
if (!right_utf) {
/* plus one for each hi-byte char if we have to upgrade */
- for (c = s; *c; c++) {
+ for (c = s; c < s + len; c++) {
if (*c & 0x80)
targlen++;
}
}
SvGROW(TARG, targlen+1);
/* And now copy, maybe upgrading right to UTF8 on the fly */
- for (c = SvEND(TARG); *s; s++) {
+ for (c = (U8*)SvEND(TARG); len--; s++) {
if (*s & 0x80 && !right_utf)
- c = (char*)uv_to_utf8((U8*)c, *s);
+ c = uv_to_utf8(c, *s);
else
*c++ = *s;
}
*SvEND(TARG) = '\0';
SvUTF8_on(TARG);
SETs(TARG);
+ Safefree(olds);
RETURN;
}
}
if (TARG != left) {
- s = SvPV(left,len);
+ s = (U8*)SvPV(left,len);
if (TARG == right) {
- sv_insert(TARG, 0, 0, s, len);
+ sv_insert(TARG, 0, 0, (char*)s, len);
SETs(TARG);
RETURN;
}
- sv_setpvn(TARG,s,len);
+ sv_setpvn(TARG, (char *)s, len);
}
else if (SvGMAGICAL(TARG))
mg_get(TARG);
else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
sv_setpv(TARG, ""); /* Suppress warning. */
- s = SvPV(right,len);
+ s = (U8*)SvPV(right,len);
if (SvOK(TARG)) {
#if defined(PERL_Y2KWARN)
if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
}
}
#endif
- sv_catpvn(TARG,s,len);
+ sv_catpvn(TARG, (char *)s, len);
}
else
- sv_setpvn(TARG,s,len); /* suppress warning */
+ sv_setpvn(TARG, (char *)s, len); /* suppress warning */
if (left_utf)
SvUTF8_on(TARG);
SETTARG;
tryAMAGICunTARGET(iter, 0);
PL_last_in_gv = (GV*)(*PL_stack_sp--);
if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
- if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
+ if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
else {
dSP;
PP(pp_eq)
{
- djSP; tryAMAGICbinSET(eq,0);
+ djSP; tryAMAGICbinSET(eq,0);
{
dPOPnv;
SETs(boolSV(TOPn == value));
PP(pp_add)
{
- djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
dPOPTOPnnrl_ul;
SETn( left + right );
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
+ /* If using default handle then we need to make space to
* pass object as 1st arg, so move other args up ...
*/
MEXTEND(SP, 1);
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;
}
else {
GV *gv;
-
+
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
STRLEN len;
if (GIMME == G_ARRAY) {
I32 maxarg = AvFILL(av) + 1;
(void)POPs; /* XXXX May be optimized away? */
- EXTEND(SP, maxarg);
+ EXTEND(SP, maxarg);
if (SvRMAGICAL(av)) {
- U32 i;
+ U32 i;
for (i=0; i < maxarg; i++) {
SV **svp = av_fetch(av, i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
- }
+ }
else {
Copy(AvARRAY(av), SP+1, maxarg, SV*);
}
}
else {
GV *gv;
-
+
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
STRLEN len;
MAGIC* mg = mg_find(TARG, 'g');
if (mg && mg->mg_len >= 0) {
if (!(rx->reganch & ROPT_GPOS_SEEN))
- rx->endp[0] = rx->startp[0] = mg->mg_len;
+ rx->endp[0] = rx->startp[0] = mg->mg_len;
else if (rx->reganch & ROPT_ANCH_GPOS) {
r_flags |= REXEC_IGNOREPOS;
- rx->endp[0] = rx->startp[0] = mg->mg_len;
+ rx->endp[0] = rx->startp[0] = mg->mg_len;
}
minmatch = (mg->mg_flags & MGf_MINMATCH);
update_minmatch = 0;
if ((gimme != G_ARRAY && !global && rx->nparens)
|| SvTEMP(TARG) || PL_sawampersand)
r_flags |= REXEC_COPY_STR;
- if (SvSCREAM(TARG))
+ if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
if (!s)
goto nope;
if ( (rx->reganch & ROPT_CHECK_ALL)
- && !PL_sawampersand
+ && !PL_sawampersand
&& ((rx->reganch & ROPT_NOSCAN)
|| !((rx->reganch & RE_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM)))
rx->endp[0] = s - truebase + rx->minlen;
rx->sublen = strend - truebase;
goto gotcha;
- }
+ }
if (PL_sawampersand) {
I32 off;
&& (IoTYPE(io) == '>' || 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) {
"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);
U32 lval = PL_op->op_flags & OPf_MOD;
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
+ U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
if (SvTYPE(hv) == SVt_PVHV) {
- he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
+ he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : 0;
}
else if (SvTYPE(hv) == SVt_PVAV) {
if (PL_op->op_private & OPpLVAL_INTRO)
DIE(aTHX_ "Can't localize pseudo-hash element");
- svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
+ svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
}
else {
RETPUSHUNDEF;
/* safe to reuse old SV */
sv_setsv(*itersvp, cur);
}
- else
+ else
#endif
{
/* we need a fresh SV every time so that loop body sees a
/* safe to reuse old SV */
sv_setiv(*itersvp, cx->blk_loop.iterix++);
}
- else
+ else
#endif
{
/* we need a fresh SV every time so that loop body sees a
SvREFCNT_dec(*itersvp);
if ((sv = SvMAGICAL(av)
- ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
+ ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
: AvARRAY(av)[++cx->blk_loop.iterix]))
SvTEMP_off(sv);
else
else {
TARG = DEFSV;
EXTEND(SP,1);
- }
+ }
+ if (SvFAKE(TARG) && SvREADONLY(TARG))
+ sv_force_normal(TARG);
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
DIE(aTHX_ "panic: do_subst");
strend = s + len;
- maxiters = 2*(strend - s) + 10; /* We can match twice at each
+ maxiters = 2*(strend - s) + 10; /* We can match twice at each
position, once with zero-length,
second time with non-zero. */
goto nope;
/* How to do it in subst? */
/* if ( (rx->reganch & ROPT_CHECK_ALL)
- && !PL_sawampersand
+ && !PL_sawampersand
&& ((rx->reganch & ROPT_NOSCAN)
|| !((rx->reganch & RE_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM))))
goto ret_no;
nope:
-ret_no:
+ret_no:
SPAGAIN;
PUSHs(&PL_sv_no);
LEAVE_SCOPE(oldsave);
SV *sv;
POPBLOCK(cx,newpm);
-
+
TAINT_NOT;
if (gimme == G_SCALAR) {
MARK = newsp + 1;
}
}
PUTBACK;
-
+
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
SV *sv;
POPBLOCK(cx,newpm);
-
+
TAINT_NOT;
if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
}
}
PUTBACK;
-
+
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
save_item(dbsv);
if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
- || strEQ(GvNAME(gv), "END")
+ || strEQ(GvNAME(gv), "END")
|| ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
!( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
&& (gv = (GV*)*svp) ))) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
- sv_setsv(dbsv, newRV((SV*)cv));
+ SV *tmp = newRV((SV*)cv);
+ sv_setsv(dbsv, tmp);
+ SvREFCNT_dec(tmp);
}
else {
gv_efullname3(dbsv, gv, Nullch);
}
PL_stack_sp = mark + 1;
fp3 = (I32(*)(int,int,int))CvXSUB(cv);
- items = (*fp3)(CvXSUBANY(cv).any_i32,
+ items = (*fp3)(CvXSUBANY(cv).any_i32,
MARK - PL_stack_base + 1,
items);
PL_stack_sp = PL_stack_base + items;
EXTEND(SP, items);
Copy(AvARRAY(av), SP + 1, items, SV*);
SP += items;
- PUTBACK ;
+ PUTBACK ;
}
}
/* We assume first XSUB in &DB::sub is the called one. */
EXTEND(SP, items);
Copy(AvARRAY(av), SP + 1, items, SV*);
SP += items;
- PUTBACK ;
+ PUTBACK ;
}
}
#endif /* USE_THREADS */
}
Copy(MARK,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
-
+
while (items--) {
if (*MARK)
SvTEMP_off(*MARK);
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
+ Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
SvPVX(tmpstr));
}
}
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))
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
- if (!packname ||
+ if (!packname ||
((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
? !isIDFIRST_utf8((U8*)packname)
: !isIDFIRST(*packname)
projects / p5sagit/p5-mst-13.2.git / blobdiff