/* pp_hot.c
*
- * Copyright (c) 1991-2003, 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.
if (TARG == right && right != left) {
right = sv_2mortal(newSVpvn(rpv, rlen));
- rpv = SvPV(right, rlen); /* no point setting UTF8 here */
+ rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
rcopied = TRUE;
}
{
dSP; dTOPss;
HV *hv;
+ I32 gimme = GIMME_V;
if (SvROK(sv)) {
wasref:
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
+ if (gimme != G_ARRAY)
Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
SETs((SV*)hv);
RETURN;
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
+ if (gimme != G_ARRAY)
Perl_croak(aTHX_ "Can't return hash to lvalue"
" scalar context");
SETs((SV*)hv);
DIE(aTHX_ PL_no_usym, "a HASH");
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
- if (GIMME == G_ARRAY) {
+ if (gimme == G_ARRAY) {
SP--;
RETURN;
}
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
+ if (gimme != G_ARRAY)
Perl_croak(aTHX_ "Can't return hash to lvalue"
" scalar context");
SETs((SV*)hv);
}
}
- if (GIMME == G_ARRAY) { /* array wanted */
+ if (gimme == G_ARRAY) { /* array wanted */
*PL_stack_sp = (SV*)hv;
return do_kv();
}
- else {
+ else if (gimme == G_SCALAR) {
dTARGET;
+ if (SvRMAGICAL(hv) && mg_find((SV *)hv, PERL_MAGIC_tied))
+ Perl_croak(aTHX_ "Can't provide tied hash usage; "
+ "use keys(%%hash) to test if empty");
if (HvFILL(hv))
Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
(IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
sv_setiv(TARG, 0);
SETTARG;
- RETURN;
}
+ RETURN;
}
STATIC void
if (PL_delaymagic & ~DM_DELAY) {
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
+ (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
+ (Uid_t)-1);
#else
# ifdef HAS_SETREUID
- (void)setreuid(PL_uid,PL_euid);
+ (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(PL_uid);
+ (void)seteuid(PL_euid);
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
}
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
+ (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
+ (Gid_t)-1);
#else
# ifdef HAS_SETREGID
- (void)setregid(PL_gid,PL_egid);
+ (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(PL_gid);
+ (void)setegid(PL_egid);
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+ if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
}
rx->startp[0] = s - truebase;
rx->endp[0] = s - truebase + rx->minlen;
}
- rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
+ rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
LEAVE_SCOPE(oldsave);
RETPUSHYES;
/* undef TARG, and push that undefined value */
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
- SvOK_off(TARG);
+ (void)SvOK_off(TARG);
}
PUSHTARG;
}
sv_unref(sv);
(void)SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen)
+ if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (gimme == G_SCALAR) {
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
- SvOK_off(TARG);
+ (void)SvOK_off(TARG);
}
SPAGAIN;
PUSHTARG;
(void)POPs; /* Unmatched wildcard? Chuck it... */
continue;
}
+ } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
+ U8 *s = (U8*)SvPVX(sv) + offset;
+ STRLEN len = SvCUR(sv) - offset;
+ U8 *f;
+
+ if (ckWARN(WARN_UTF8) &&
+ !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
+ /* Emulate :encoding(utf8) warning in the same case. */
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "utf8 \"\\x%02X\" does not map to Unicode",
+ f < (U8*)SvEND(sv) ? *f : 0);
}
if (gimme == G_ARRAY) {
if (SvLEN(sv) - SvCUR(sv) > 20) {
else {
sv = AvARRAY(av)[++cx->blk_loop.iterix];
}
+ if (sv && SvREFCNT(sv) == 0) {
+ *itersvp = Nullsv;
+ Perl_croak(aTHX_ "Use of freed value in iteration");
+ }
+
if (sv)
SvTEMP_off(sv);
else
? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+ if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
}
if (!c) {
register PERL_CONTEXT *cx;
SPAGAIN;
+ ReREFCNT_inc(rx);
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplroot);
}
SV *sv;
POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
TAINT_NOT;
if (gimme == G_SCALAR) {
PUTBACK;
LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
SV *sv;
POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
TAINT_NOT;
* TEMP, so sv_2mortal is out of question. */
if (!CvLVALUE(cx->blk_sub.cv)) {
LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
if (MARK == SP) {
if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
}
else { /* Should not happen? */
LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
/* Might be flattened array after $#array = */
PUTBACK;
LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
PUTBACK;
LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
/* this isn't a reference */
packname = Nullch;
+
+ if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
+ HE* he;
+ he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
+ if (he) {
+ stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+ goto fetch;
+ }
+ }
+
if (!SvOK(sv) ||
- !(packname = SvPV(sv, packlen)) ||
+ !(packname) ||
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
stash = gv_stashpvn(packname, packlen, FALSE);
if (!stash)
packsv = sv;
+ else {
+ SV* ref = newSViv(PTR2IV(stash));
+ hv_store(PL_stashcache, packname, packlen, ref, 0);
+ }
goto fetch;
}
/* it _is_ a filehandle name -- replace with a reference */
/* the method name is unqualified or starts with SUPER:: */
packname = sep ? CopSTASHPV(PL_curcop) :
stash ? HvNAME(stash) : packname;
- packlen = strlen(packname);
+ if (!packname)
+ Perl_croak(aTHX_
+ "Can't use anonymous symbol table for method lookup");
+ else
+ packlen = strlen(packname);
}
else {
/* the method name is qualified */