/* pp_hot.c
*
- * Copyright (c) 1991-1999, Larry Wall
+ * Copyright (c) 1991-2000, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#ifdef I_UNISTD
#include <unistd.h>
#endif
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
-
-#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off))
/* Hot code. */
PP(pp_const)
{
djSP;
- XPUSHs(cSVOP->op_sv);
+ XPUSHs(cSVOP_sv);
RETURN;
}
djSP;
EXTEND(SP,1);
if (PL_op->op_private & OPpLVAL_INTRO)
- PUSHs(save_scalar((GV*)cSVOP->op_sv));
+ PUSHs(save_scalar(cGVOP_gv));
else
- PUSHs(GvSV((GV*)cSVOP->op_sv));
+ PUSHs(GvSV(cGVOP_gv));
RETURN;
}
char *s;
s = SvPV(TOPs,len);
sv_setpvn(TARG,s,len);
+ if (SvUTF8(TOPs) && !IN_BYTE)
+ SvUTF8_on(TARG);
SETTARG;
RETURN;
}
PP(pp_gv)
{
djSP;
- XPUSHs(cSVOP->op_sv);
+ XPUSHs((SV*)cGVOP_gv);
RETURN;
}
PP(pp_sassign)
{
djSP; dPOPTOPssrl;
- MAGIC *mg;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
SV *temp;
dPOPTOPssrl;
STRLEN len;
char *s;
+
if (TARG != left) {
s = SvPV(left,len);
+ if (TARG == right) {
+ sv_insert(TARG, 0, 0, s, len);
+ SETs(TARG);
+ RETURN;
+ }
sv_setpvn(TARG,s,len);
}
else if (SvGMAGICAL(TARG))
s = SvPV(right,len);
if (SvOK(TARG)) {
#if defined(PERL_Y2KWARN)
- if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_MISC)) {
+ 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_MISC, "Possible Y2K bug: %s",
+ Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
"about to append an integer to '19'");
}
}
#endif
+ if (DO_UTF8(right))
+ sv_utf8_upgrade(TARG);
sv_catpvn(TARG,s,len);
+ if (!IN_BYTE) {
+ if (SvUTF8(right))
+ SvUTF8_on(TARG);
+ }
+ else if (!SvUTF8(right)) {
+ SvUTF8_off(TARG);
+ }
}
else
sv_setpvn(TARG,s,len); /* suppress warning */
PP(pp_aelemfast)
{
djSP;
- AV *av = GvAV((GV*)cSVOP->op_sv);
+ AV *av = GvAV(cGVOP_gv);
U32 lval = PL_op->op_flags & OPf_MOD;
SV** svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
* pass object as 1st arg, so move other args up ...
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED, WARN_IO)) {
- SV* sv = sv_newmortal();
- gv_efullname3(sv, gv, Nullch);
- if (IoIFP(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));
+ }
else if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED,
- "print on closed filehandle %s", SvPV(sv,n_a));
+ report_closed_fh(gv, io, "print", "filehandle");
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "an ARRAY");
if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
+ report_uninit();
if (GIMME == G_ARRAY) {
(void)POPs;
RETURN;
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a HASH");
if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
+ report_uninit();
if (GIMME == G_ARRAY) {
SP--;
RETURN;
}
}
+STATIC int
+S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
+ SV **lastrelem)
+{
+ OP *leftop;
+ I32 i;
+
+ leftop = ((BINOP*)PL_op)->op_last;
+ assert(leftop);
+ assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
+ leftop = ((LISTOP*)leftop)->op_first;
+ assert(leftop);
+ /* Skip PUSHMARK and each element already assigned to. */
+ for (i = lelem - firstlelem; i > 0; i--) {
+ leftop = leftop->op_sibling;
+ assert(leftop);
+ }
+ if (leftop->op_type != OP_RV2HV)
+ return 0;
+
+ /* pseudohash */
+ if (av_len(ary) > 0)
+ av_fill(ary, 0); /* clear all but the fields hash */
+ if (lastrelem >= relem) {
+ while (relem < lastrelem) { /* gobble up all the rest */
+ SV *tmpstr;
+ assert(relem[0]);
+ assert(relem[1]);
+ /* Avoid a memory leak when avhv_store_ent dies. */
+ tmpstr = sv_newmortal();
+ sv_setsv(tmpstr,relem[1]); /* value */
+ relem[1] = tmpstr;
+ if (avhv_store_ent(ary,relem[0],tmpstr,0))
+ (void)SvREFCNT_inc(tmpstr);
+ if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ relem += 2;
+ TAINT_NOT;
+ }
+ }
+ if (relem == lastrelem)
+ return 1;
+ return 2;
+}
+
+STATIC void
+S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
+{
+ if (*relem) {
+ SV *tmpstr;
+ if (ckWARN(WARN_MISC)) {
+ if (relem == firstrelem &&
+ SvROK(*relem) &&
+ (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
+ SvTYPE(SvRV(*relem)) == SVt_PVHV))
+ {
+ Perl_warner(aTHX_ WARN_MISC,
+ "Reference found where even-sized list expected");
+ }
+ else
+ Perl_warner(aTHX_ WARN_MISC,
+ "Odd number of elements in hash assignment");
+ }
+ if (SvTYPE(hash) == SVt_PVAV) {
+ /* pseudohash */
+ tmpstr = sv_newmortal();
+ if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
+ (void)SvREFCNT_inc(tmpstr);
+ if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ }
+ else {
+ HE *didstore;
+ tmpstr = NEWSV(29,0);
+ didstore = hv_store_ent(hash,*relem,tmpstr,0);
+ if (SvMAGICAL(hash)) {
+ if (SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ if (!didstore)
+ sv_2mortal(tmpstr);
+ }
+ }
+ TAINT_NOT;
+ }
+}
+
PP(pp_aassign)
{
djSP;
* special care that assigning the identifier on the left doesn't
* clobber a value on the right that's used later in the list.
*/
- if (PL_op->op_private & OPpASSIGN_COMMON) {
+ if (PL_op->op_private & (OPpASSIGN_COMMON)) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
- for (relem = firstrelem; relem <= lastrelem; relem++) {
- /*SUPPRESS 560*/
- if (sv = *relem) {
+ for (relem = firstrelem; relem <= lastrelem; relem++) {
+ /*SUPPRESS 560*/
+ if ((sv = *relem)) {
TAINT_NOT; /* Each item is independent */
- *relem = sv_mortalcopy(sv);
+ *relem = sv_mortalcopy(sv);
}
- }
+ }
}
relem = firstrelem;
lelem = firstlelem;
ary = Null(AV*);
hash = Null(HV*);
+
while (lelem <= lastlelem) {
TAINT_NOT; /* Each item stands on its own, taintwise. */
sv = *lelem++;
case SVt_PVAV:
ary = (AV*)sv;
magic = SvMAGICAL(ary) != 0;
-
+ if (PL_op->op_private & OPpASSIGN_HASH) {
+ switch (do_maybe_phash(ary, lelem, firstlelem, relem,
+ lastrelem))
+ {
+ case 0:
+ goto normal_array;
+ case 1:
+ do_oddball((HV*)ary, relem, firstrelem);
+ }
+ relem = lastrelem + 1;
+ break;
+ }
+ normal_array:
av_clear(ary);
av_extend(ary, lastrelem - relem);
i = 0;
TAINT_NOT;
}
break;
- case SVt_PVHV: {
+ case SVt_PVHV: { /* normal hash */
SV *tmpstr;
hash = (HV*)sv;
TAINT_NOT;
}
if (relem == lastrelem) {
- if (*relem) {
- HE *didstore;
- if (ckWARN(WARN_UNSAFE)) {
- if (relem == firstrelem &&
- SvROK(*relem) &&
- ( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
- SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
- Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected");
- else
- Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
- }
- tmpstr = NEWSV(29,0);
- didstore = hv_store_ent(hash,*relem,tmpstr,0);
- if (magic) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
- }
- TAINT_NOT;
- }
+ do_oddball(hash, relem, firstrelem);
relem++;
}
}
truebase = t = s;
/* XXXX What part of this is needed with true \G-support? */
- if (global = pm->op_pmflags & PMf_GLOBAL) {
+ if ((global = pm->op_pmflags & PMf_GLOBAL)) {
rx->startp[0] = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, 'g');
len = rx->endp[i] - rx->startp[i];
s = rx->startp[i] + truebase;
sv_setpvn(*SP, s, len);
+ if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
+ SvUTF8_on(*SP);
+ sv_utf8_downgrade(*SP, TRUE);
+ }
}
}
if (global) {
rx->startp[0] = s - truebase;
rx->endp[0] = s - truebase + rx->minlen;
}
+ rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
LEAVE_SCOPE(oldsave);
RETPUSHYES;
I32 gimme = GIMME_V;
MAGIC *mg;
- if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
PUTBACK;
}
}
#else /* !VMS */
+#ifdef MACOS_TRADITIONAL
+ sv_setpv(tmpcmd, "glob ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, " |");
+#else
#ifdef DOSISH
#ifdef OS2
sv_setpv(tmpcmd, "for a in ");
#endif
#endif /* !CSH */
#endif /* !DOSISH */
+#endif /* MACOS_TRADITIONAL */
(void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
FALSE, O_RDONLY, 0, Nullfp);
fp = IoIFP(io);
}
}
if (!fp) {
- if (ckWARN(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_CLOSED,
+ Perl_warner(aTHX_ WARN_GLOB,
"glob failed (can't start child: %s)",
Strerror(errno));
- else {
- SV* sv = sv_newmortal();
- gv_efullname3(sv, PL_last_in_gv, Nullch);
- Perl_warner(aTHX_ WARN_CLOSED,
- "Read on closed filehandle %s",
- SvPV_nolen(sv));
- }
+ else
+ report_closed_fh(PL_last_in_gv, io, "readline", "filehandle");
}
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
offset = 0;
}
-/* flip-flop EOF state for a snarfed empty file */
+/* delay EOF state for a snarfed empty file */
#define SNARF_EOF(gimme,rs,io,sv) \
- ((gimme != G_SCALAR || SvCUR(sv) \
- || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \
- ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \
- : ((IoFLAGS(io) |= IOf_NOLINE), FALSE))
+ (gimme != G_SCALAR || SvCUR(sv) \
+ || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE) \
+ || ((IoFLAGS(io) |= IOf_NOLINE), FALSE))
for (;;) {
if (!sv_gets(sv, fp, offset)
(void)do_close(PL_last_in_gv, FALSE);
}
else if (type == OP_GLOB) {
- if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
- Perl_warner(aTHX_ WARN_CLOSED,
+ if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
+ Perl_warner(aTHX_ WARN_GLOB,
"glob failed (child exited with status %d%s)",
- STATUS_CURRENT >> 8,
+ (int)(STATUS_CURRENT >> 8),
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
}
register PERL_CONTEXT *cx;
SV* sv;
AV* av;
+ SV **itersvp;
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
if (CxTYPE(cx) != CXt_LOOP)
DIE(aTHX_ "panic: pp_iter");
+ itersvp = CxITERVAR(cx);
av = cx->blk_loop.iterary;
if (SvTYPE(av) != SVt_PVAV) {
/* iterate ($min .. $max) */
char *max = SvPV((SV*)av, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1
- && !SvMAGICAL(*cx->blk_loop.itervar))
- {
+ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setsv(*cx->blk_loop.itervar, cur);
+ sv_setsv(*itersvp, cur);
}
else
#endif
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as
* they used to */
- SvREFCNT_dec(*cx->blk_loop.itervar);
- *cx->blk_loop.itervar = newSVsv(cur);
+ SvREFCNT_dec(*itersvp);
+ *itersvp = newSVsv(cur);
}
if (strEQ(SvPVX(cur), max))
sv_setiv(cur, 0); /* terminate next time */
RETPUSHNO;
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1
- && !SvMAGICAL(*cx->blk_loop.itervar))
- {
+ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++);
+ sv_setiv(*itersvp, cx->blk_loop.iterix++);
}
else
#endif
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as they
* used to */
- SvREFCNT_dec(*cx->blk_loop.itervar);
- *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++);
+ SvREFCNT_dec(*itersvp);
+ *itersvp = newSViv(cx->blk_loop.iterix++);
}
RETPUSHYES;
}
if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
RETPUSHNO;
- SvREFCNT_dec(*cx->blk_loop.itervar);
+ SvREFCNT_dec(*itersvp);
- if (sv = (SvMAGICAL(av))
- ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
- : AvARRAY(av)[++cx->blk_loop.iterix])
+ if ((sv = SvMAGICAL(av)
+ ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
+ : AvARRAY(av)[++cx->blk_loop.iterix]))
SvTEMP_off(sv);
else
sv = &PL_sv_undef;
sv = (SV*)lv;
}
- *cx->blk_loop.itervar = SvREFCNT_inc(sv);
+ *itersvp = SvREFCNT_inc(sv);
RETPUSHYES;
}
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
- I32 update_minmatch = 1;
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
SvCUR_set(TARG, m - s);
}
/*SUPPRESS 560*/
- else if (i = m - s) { /* faster from front */
+ else if ((i = m - s)) { /* faster from front */
d -= clen;
m = d;
sv_chop(TARG, d-i);
rxtainted |= RX_MATCH_TAINTED(rx);
m = rx->startp[0] + orig;
/*SUPPRESS 560*/
- if (i = m - s) {
+ if ((i = m - s)) {
if (s != d)
Move(s, d, i, char);
d += i;
SV *src;
ENTER; /* enter inner scope */
- SAVESPTR(PL_curpm);
+ SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
sv_2mortal(*MARK);
}
else {
+ sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
FREETMPS;
- *MARK = sv_mortalcopy(TOPs);
+ *MARK = sv_mortalcopy(sv);
+ SvREFCNT_dec(sv);
}
}
else
: "an uninitialized value");
}
else {
- mortalize:
/* Can be a localized value subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *mark;
(void)SvREFCNT_inc(*mark);
sv_2mortal(*MARK);
}
else {
+ sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
FREETMPS;
- *MARK = sv_mortalcopy(TOPs);
+ *MARK = sv_mortalcopy(sv);
+ SvREFCNT_dec(sv);
}
}
else
}
}
else {
- SvUPGRADE(dbsv, SVt_PVIV);
- SvIOK_on(dbsv);
+ (void)SvUPGRADE(dbsv, SVt_PVIV);
+ (void)SvIOK_on(dbsv);
SAVEIV(SvIVX(dbsv));
SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
}
SP--;
}
PL_stack_sp = mark + 1;
- fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
+ fp3 = (I32(*)(int,int,int))CvXSUB(cv);
items = (*fp3)(CvXSUBANY(cv).any_i32,
MARK - PL_stack_base + 1,
items);
}
/* We assume first XSUB in &DB::sub is the called one. */
if (PL_curcopdb) {
- SAVESPTR(PL_curcop);
+ SAVEVPTR(PL_curcop);
PL_curcop = PL_curcopdb;
PL_curcopdb = NULL;
}
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
+ PERL_STACK_OVERFLOW_CHECK();
if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *av;
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
I32 ix = AvFILLp((AV*)svp[1]);
+ I32 names_fill = AvFILLp((AV*)svp[0]);
svp = AvARRAY(svp[0]);
for ( ;ix > 0; ix--) {
- if (svp[ix] != &PL_sv_undef) {
+ if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
char *name = SvPVX(svp[ix]);
if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
|| *name == '&') /* anonymous code? */
SvPADMY_on(sv);
}
}
+ else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
+ }
else {
av_store(newpad, ix, sv = NEWSV(0,0));
SvPADTMP_on(sv);
}
}
#endif /* USE_THREADS */
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
#ifndef USE_THREADS
if (hasargs)
STATIC SV *
S_method_common(pTHX_ SV* meth, U32* hashp)
{
- djSP;
SV* sv;
SV* ob;
GV* gv;
!(ob=(SV*)GvIO(iogv)))
{
if (!packname ||
- ((*(U8*)packname >= 0xc0 && IN_UTF8)
+ ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
? !isIDFIRST_utf8((U8*)packname)
: !isIDFIRST(*packname)
))
*(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
}
- if (!ob || !SvOBJECT(ob))
+ if (!ob || !(SvOBJECT(ob)
+ || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
+ && SvOBJECT(ob))))
+ {
Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
name);
+ }
stash = SvSTASH(ob);
sep = p, leaf = p + 2;
}
if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
- packname = HvNAME(sep ? PL_curcop->cop_stash : stash);
+ packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
packlen = strlen(packname);
}
else {
https://perl5.git.perl.org / perl5.git / blobdiff