#include "EXTERN.h"
#include "perl.h"
+#ifdef PERL_OBJECT
+#define CHECKCALL this->*check
+#else
+#define CHECKCALL *check
+#endif
+
/*
* In the following definition, the ", Nullop" is just to make the compiler
* think the expression is of the right type: croak actually does a Siglongjmp.
? ( op_free((OP*)o), \
croak("%s trapped by operation mask", op_desc[type]), \
Nullop ) \
- : (*check[type])((OP*)o))
+ : (CHECKCALL[type])((OP*)o))
+static bool scalar_mod_type _((OP *o, I32 type));
+#ifndef PERL_OBJECT
static I32 list_assignment _((OP *o));
static void bad_type _((I32 n, char *t, char *name, OP *kid));
static OP *modkids _((OP *o, I32 type));
static OP *no_fh_allowed _((OP *o));
-static bool scalar_mod_type _((OP *o, I32 type));
static OP *scalarboolean _((OP *o));
static OP *too_few_arguments _((OP *o, char* name));
static OP *too_many_arguments _((OP *o, char* name));
static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
CV* startcv, I32 cx_ix));
static OP *newDEFSVOP _((void));
+static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
+#endif
-static char*
+STATIC char*
gv_ename(GV *gv)
{
SV* tmpsv = sv_newmortal();
return SvPV(tmpsv,na);
}
-static OP *
+STATIC OP *
no_fh_allowed(OP *o)
{
yyerror(form("Missing comma after first argument to %s function",
return o;
}
-static OP *
+STATIC OP *
too_few_arguments(OP *o, char *name)
{
yyerror(form("Not enough arguments for %s", name));
return o;
}
-static OP *
+STATIC OP *
too_many_arguments(OP *o, char *name)
{
yyerror(form("Too many arguments for %s", name));
return o;
}
-static void
+STATIC void
bad_type(I32 n, char *t, char *name, OP *kid)
{
yyerror(form("Type of arg %d to %s must be %s (not %s)",
int type = o->op_type;
if (type != OP_AELEM && type != OP_HELEM) {
yyerror(form("Can't use subscript on %s", op_desc[type]));
- if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV)
- warn("(Did you mean $ or @ instead of %c?)\n",
- type == OP_ENTERSUB ? '&' : '%');
+ if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) {
+ dTHR;
+ SV *msg = sv_2mortal(
+ newSVpvf("(Did you mean $ or @ instead of %c?)\n",
+ type == OP_ENTERSUB ? '&' : '%'));
+ if (in_eval & 2)
+ warn("%_", msg);
+ else if (in_eval)
+ sv_catsv(GvSV(errgv), msg);
+ else
+ PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
+ }
}
}
}
croak("Can't use global %s in \"my\"",name);
}
- if (dowarn && AvFILL(comppad_name) >= 0) {
+ if (dowarn && AvFILLp(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
- for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) {
+ for (off = AvFILLp(comppad_name); off > comppad_name_floor; off--) {
if ((sv = svp[off])
&& sv != &sv_undef
&& SvIVX(sv) == 999999999 /* var is in open scope */
return off;
}
-static PADOFFSET
-#ifndef CAN_PROTOTYPE
-pad_findlex(name, newoff, seq, startcv, cx_ix)
-char *name;
-PADOFFSET newoff;
-U32 seq;
-CV* startcv;
-I32 cx_ix;
-#else
+STATIC PADOFFSET
pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
-#endif
{
dTHR;
CV *cv;
continue;
curname = (AV*)*svp;
svp = AvARRAY(curname);
- for (off = AvFILL(curname); off > 0; off--) {
+ for (off = AvFILLp(curname); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
seq <= SvIVX(sv) &&
#endif /* USE_THREADS */
/* The one we're looking for is probably just before comppad_name_fill. */
- for (off = AvFILL(comppad_name); off > 0; off--) {
+ for (off = AvFILLp(comppad_name); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
(!SvIVX(sv) ||
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
- for (off = AvFILL(comppad_name); off > fill; off--) {
+ for (off = AvFILLp(comppad_name); off > fill; off--) {
if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999)
SvIVX(sv) = cop_seqmax;
}
pad_reset();
if (tmptype & SVs_PADMY) {
do {
- sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE);
+ sv = *av_fetch(comppad, AvFILLp(comppad) + 1, TRUE);
} while (SvPADBUSY(sv)); /* need a fresh one */
- retval = AvFILL(comppad);
+ retval = AvFILLp(comppad);
}
else {
SV **names = AvARRAY(comppad_name);
- SSize_t names_fill = AvFILL(comppad_name);
+ SSize_t names_fill = AvFILLp(comppad_name);
for (;;) {
/*
* "foreach" index vars temporarily become aliases to non-"my"
(unsigned long) thr, (unsigned long) curpad,
(long) retval, op_name[optype]));
#else
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n",
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx alloc %ld for %s\n",
+ (unsigned long) curpad,
(long) retval, op_name[optype]));
#endif /* USE_THREADS */
return (PADOFFSET)retval;
}
SV *
-#ifndef CAN_PROTOTYPE
-pad_sv(po)
-PADOFFSET po;
-#else
pad_sv(PADOFFSET po)
-#endif /* CAN_PROTOTYPE */
{
dTHR;
#ifdef USE_THREADS
#else
if (!po)
croak("panic: pad_sv po");
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx sv %d\n",
+ (unsigned long) curpad, po));
#endif /* USE_THREADS */
return curpad[po]; /* eventually we'll turn this into a macro */
}
void
-#ifndef CAN_PROTOTYPE
-pad_free(po)
-PADOFFSET po;
-#else
pad_free(PADOFFSET po)
-#endif /* CAN_PROTOTYPE */
{
dTHR;
if (!curpad)
DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n",
(unsigned long) thr, (unsigned long) curpad, po));
#else
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx free %d\n",
+ (unsigned long) curpad, po));
#endif /* USE_THREADS */
if (curpad[po] && curpad[po] != &sv_undef)
SvPADTMP_off(curpad[po]);
}
void
-#ifndef CAN_PROTOTYPE
-pad_swipe(po)
-PADOFFSET po;
-#else
pad_swipe(PADOFFSET po)
-#endif /* CAN_PROTOTYPE */
{
dTHR;
if (AvARRAY(comppad) != curpad)
DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n",
(unsigned long) thr, (unsigned long) curpad, po));
#else
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx swipe %d\n",
+ (unsigned long) curpad, po));
#endif /* USE_THREADS */
SvPADTMP_off(curpad[po]);
curpad[po] = NEWSV(1107,0);
padix = po - 1;
}
+/* XXX pad_reset() is currently disabled because it results in serious bugs.
+ * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
+ * on the stack by OPs that use them, there are several ways to get an alias
+ * to a shared TARG. Such an alias will change randomly and unpredictably.
+ * We avoid doing this until we can think of a Better Way.
+ * GSAR 97-10-29 */
void
pad_reset(void)
{
+#ifdef USE_BROKEN_PAD_RESET
dTHR;
register I32 po;
DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n",
(unsigned long) thr, (unsigned long) curpad));
#else
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n"));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx reset\n",
+ (unsigned long) curpad));
#endif /* USE_THREADS */
if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */
for (po = AvMAX(comppad); po > padix_floor; po--) {
}
padix = padix_floor;
}
+#endif
pad_reset_pending = FALSE;
}
if (!svp) {
SV *sv = NEWSV(0, 0);
av_store(thr->threadsv, key, sv);
+ thr->threadsvp = AvARRAY(thr->threadsv);
/*
* Some magic variables used to be automagically initialised
* in gv_fetchpv. Those which are now per-thread magicals get
sawampersand = TRUE;
SvREADONLY_on(sv);
/* FALL THROUGH */
+
+ /* XXX %! tied to Errno.pm needs to be added here.
+ * See gv_fetchpv(). */
+ /* case '!': */
+
default:
sv_magic(sv, 0, 0, name, 1);
}
break;
#endif /* USE_THREADS */
default:
- if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst))
+ if (!(o->op_flags & OPf_REF)
+ || (check[o->op_type] != FUNC_NAME_TO_PTR(ck_ftst)))
break;
/* FALL THROUGH */
case OP_GVSV:
/* FALL THROUGH */
case OP_PUSHRE:
case OP_MATCH:
+ case OP_QR:
ReREFCNT_dec(cPMOPo->op_pmregexp);
break;
}
Safefree(o);
}
-static void
+STATIC void
null(OP *o)
{
if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0)
return o;
}
-static OP *
+STATIC OP *
scalarboolean(OP *o)
{
if (dowarn &&
}
/* FALL THROUGH */
case OP_MATCH:
+ case OP_QR:
case OP_SUBST:
case OP_NULL:
default:
case OP_REPEAT:
if (o->op_flags & OPf_STACKED)
break;
+ goto func_ops;
+ case OP_SUBSTR:
+ if (o->op_private == 4)
+ break;
/* FALL THROUGH */
case OP_GVSV:
case OP_WANTARRAY:
case OP_HEX:
case OP_OCT:
case OP_LENGTH:
- case OP_SUBSTR:
case OP_VEC:
case OP_INDEX:
case OP_RINDEX:
case OP_GGRNAM:
case OP_GGRGID:
case OP_GETLOGIN:
+ func_ops:
if (!(o->op_private & OPpLVAL_INTRO))
useless = op_desc[o->op_type];
break;
break;
default:
case OP_MATCH:
+ case OP_QR:
case OP_SUBST:
case OP_NULL:
if (!(o->op_flags & OPf_KIDS))
return o;
}
-static OP *
+STATIC OP *
modkids(OP *o, I32 type)
{
OP *kid;
return o;
}
-static I32 modcount;
-
OP *
mod(OP *o, I32 type)
{
/* FALL THROUGH */
case OP_GV:
case OP_AV2ARYLEN:
+ hints |= HINT_BLOCK_SCOPE;
case OP_SASSIGN:
case OP_AELEMFAST:
modcount++;
case OP_KEYS:
if (type != OP_SASSIGN)
goto nomod;
+ goto lvalue_func;
+ case OP_SUBSTR:
+ if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
+ goto nomod;
/* FALL THROUGH */
case OP_POS:
case OP_VEC:
- case OP_SUBSTR:
+ lvalue_func:
pad_free(o->op_targ);
o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
else if (!type) {
o->op_private |= OPpLVAL_INTRO;
o->op_flags &= ~OPf_SPECIAL;
+ hints |= HINT_BLOCK_SCOPE;
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB)
o->op_flags |= OPf_REF;
case OP_CONCAT:
case OP_SUBST:
case OP_TRANS:
+ case OP_READ:
+ case OP_SYSREAD:
+ case OP_RECV:
case OP_ANDASSIGN: /* may work later */
case OP_ORASSIGN: /* may work later */
return TRUE;
if (type == OP_LIST) {
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my(kid);
- }
- else if (type != OP_PADSV &&
+ } else if (type == OP_UNDEF) {
+ return o;
+ } else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
type != OP_PUSHMARK)
return o;
}
+void
+save_hints(void)
+{
+ SAVEI32(hints);
+ SAVESPTR(GvHV(hintgv));
+ GvHV(hintgv) = newHVhv(GvHV(hintgv));
+ SAVEFREESV(GvHV(hintgv));
+}
+
int
block_start(int full)
{
dTHR;
int retval = savestack_ix;
+
SAVEI32(comppad_name_floor);
if (full) {
- if ((comppad_name_fill = AvFILL(comppad_name)) > 0)
+ if ((comppad_name_fill = AvFILLp(comppad_name)) > 0)
comppad_name_floor = comppad_name_fill;
else
comppad_name_floor = 0;
SAVEI32(padix_floor);
padix_floor = padix;
pad_reset_pending = FALSE;
- SAVEI32(hints);
+ SAVEHINTS();
hints &= ~HINT_BLOCK_SCOPE;
return retval;
}
return retval;
}
-static OP *
+STATIC OP *
newDEFSVOP(void)
{
#ifdef USE_THREADS
CV *cv = perl_get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
- PUSHMARK(sp);
+ PUSHMARK(SP);
XPUSHs((SV*)compiling.cop_filegv);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
if (o->op_flags & OPf_PARENS)
list(o);
else {
- scalar(o);
if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') {
char *s;
for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
case OP_LCFIRST:
case OP_UC:
case OP_LC:
+ case OP_SLT:
+ case OP_SGT:
+ case OP_SLE:
+ case OP_SGE:
+ case OP_SCMP:
+
if (o->op_private & OPpLOCALE)
goto nope;
}
curop = LINKLIST(o);
o->op_next = 0;
op = curop;
- runops();
+ CALLRUNOPS();
sv = *(stack_sp--);
if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
pad_swipe(o->op_targ);
if (type == OP_RV2GV)
return newGVOP(OP_GV, 0, (GV*)sv);
else {
- if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) {
+ /* try to smush double to int, but don't smush -2.0 to -2 */
+ if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
+ type != OP_NEGATE)
+ {
IV iv = SvIV(sv);
- if ((double)iv == SvNV(sv)) { /* can we smush double to int */
+ if ((double)iv == SvNV(sv)) {
SvREFCNT_dec(sv);
sv = newSViv(iv);
}
op = curop = LINKLIST(o);
o->op_next = 0;
pp_pushmark(ARGS);
- runops();
+ CALLRUNOPS();
op = curop;
pp_anonlist(ARGS);
tmps_floor = oldtmps_floor;
unop->op_first = first;
unop->op_flags = flags | OPf_KIDS;
unop->op_private = 1 | (flags >> 8);
-#if 1
- if(type == OP_STUDY && first->op_type == OP_MATCH) {
- first->op_type = OP_PUSHRE;
- first->op_ppaddr = ppaddr[OP_PUSHRE];
- }
-#endif
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
return (OP*)unop;
pmop->op_flags = flags;
pmop->op_private = 0 | (flags >> 8);
+ if (hints & HINT_RE_TAINT)
+ pmop->op_pmpermflags |= PMf_RETAINT;
if (hints & HINT_LOCALE)
- pmop->op_pmpermflags = (pmop->op_pmflags |= PMf_LOCALE);
+ pmop->op_pmpermflags |= PMf_LOCALE;
+ pmop->op_pmflags = pmop->op_pmpermflags;
/* link into pm list */
if (type != OP_TRANS && curstash) {
OP *
pmruntime(OP *o, OP *expr, OP *repl)
{
+ dTHR;
PMOP *pm;
LOGOP *rcop;
+ I32 repl_has_vars = 0;
if (o->op_type == OP_TRANS)
return pmtrans(o, expr, repl);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
- pm->op_pmregexp = pregcomp(p, p + plen, pm);
+ pm->op_pmregexp = CALLREGCOMP(p, p + plen, pm);
if (strEQ("\\s+", pm->op_pmregexp->precomp))
pm->op_pmflags |= PMf_WHITE;
op_free(expr);
}
else {
- if (pm->op_pmflags & PMf_KEEP)
- expr = newUNOP(OP_REGCMAYBE,0,expr);
+ if (pm->op_pmflags & PMf_KEEP || !(hints & HINT_RE_EVAL))
+ expr = newUNOP((!(hints & HINT_RE_EVAL)
+ ? OP_REGCRESET
+ : OP_REGCMAYBE),0,expr);
Newz(1101, rcop, 1, LOGOP);
rcop->op_type = OP_REGCOMP;
rcop->op_ppaddr = ppaddr[OP_REGCOMP];
rcop->op_first = scalar(expr);
- rcop->op_flags |= OPf_KIDS;
+ rcop->op_flags |= ((hints & HINT_RE_EVAL)
+ ? (OPf_SPECIAL | OPf_KIDS)
+ : OPf_KIDS);
rcop->op_private = 1;
rcop->op_other = o;
/* establish postfix order */
- if (pm->op_pmflags & PMf_KEEP) {
+ if (pm->op_pmflags & PMf_KEEP || !(hints & HINT_RE_EVAL)) {
LINKLIST(expr);
rcop->op_next = expr;
((UNOP*)expr)->op_first->op_next = (OP*)rcop;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (opargs[curop->op_type] & OA_DANGEROUS) {
#ifdef USE_THREADS
- if (curop->op_type == OP_THREADSV
- && strchr("&`'123456789+", curop->op_private)) {
- break;
+ if (curop->op_type == OP_THREADSV) {
+ repl_has_vars = 1;
+ if (strchr("&`'123456789+", curop->op_private))
+ break;
}
#else
if (curop->op_type == OP_GV) {
GV *gv = ((GVOP*)curop)->op_gv;
+ repl_has_vars = 1;
if (strchr("&`'123456789+", *GvENAME(gv)))
break;
}
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
curop->op_type == OP_PADANY) {
- /* is okay */
+ repl_has_vars = 1;
}
+ else if (curop->op_type == OP_PUSHRE)
+ ; /* Okay here, dangerous in newASSIGNOP */
else
break;
}
lastop = curop;
}
}
- if (curop == repl) {
+ if (curop == repl
+ && !(repl_has_vars
+ && (!pm->op_pmregexp
+ || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
pm->op_pmflags |= PMf_CONST; /* const for long enough */
pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
}
else {
+ if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
+ pm->op_pmflags |= PMf_MAYBE_CONST;
+ pm->op_pmpermflags |= PMf_MAYBE_CONST;
+ }
Newz(1101, rcop, 1, LOGOP);
rcop->op_type = OP_SUBSTCONT;
rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
list(force_list(listval)) );
}
-static I32
+STATIC I32
list_assignment(register OP *o)
{
if (!o)
}
if (list_assignment(left)) {
+ dTHR;
modcount = 0;
eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
left = mod(left, OP_AASSIGN);
list(force_list(left)) );
o->op_private = 0 | (flags >> 8);
if (!(left->op_private & OPpLVAL_INTRO)) {
- static int generation = 100;
OP *curop;
OP *lastop = o;
generation++;
if (lastop->op_type != OP_GV) /* funny deref? */
break;
}
+ else if (curop->op_type == OP_PUSHRE) {
+ if (((PMOP*)curop)->op_pmreplroot) {
+ GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
+ if (gv == defgv || SvCUR(gv) == generation)
+ break;
+ SvCUR(gv) = generation;
+ }
+ }
else
break;
}
OP *
newLOGOP(I32 type, I32 flags, OP *first, OP *other)
{
+ return new_logop(type, flags, &first, &other);
+}
+
+STATIC OP *
+new_logop(I32 type, I32 flags, OP** firstp, OP** otherp)
+{
dTHR;
LOGOP *logop;
OP *o;
+ OP *first = *firstp;
+ OP *other = *otherp;
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
else
type = OP_AND;
o = first;
- first = cUNOPo->op_first;
+ first = *firstp = cUNOPo->op_first;
if (o->op_next)
first->op_next = o->op_next;
cUNOPo->op_first = Nullop;
warn("Probable precedence problem on %s", op_desc[type]);
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
+ *firstp = Nullop;
return other;
}
else {
op_free(other);
+ *otherp = Nullop;
return first;
}
}
case OP_NULL:
if (k2 && k2->op_type == OP_READLINE
&& (k2->op_flags & OPf_STACKED)
- && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV))
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
warnop = k2->op_type;
break;
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr->op_flags & OPf_KIDS) {
+ OP *k1 = ((UNOP*)expr)->op_first;
+ OP *k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || k1->op_type == OP_EACH)
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
}
}
listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
- o = newLOGOP(OP_AND, 0, expr, listop);
+ o = new_logop(OP_AND, 0, &expr, &listop);
- ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
+ if (listop)
+ ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
if (once && o != listop)
o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr && (expr->op_flags & OPf_KIDS)) {
+ OP *k1 = ((UNOP*)expr)->op_first;
+ OP *k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || k1->op_type == OP_EACH)
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
}
if (!block)
redo = LINKLIST(listop);
if (expr) {
- o = newLOGOP(OP_AND, 0, expr, scalar(listop));
+ copline = whileline;
+ scalar(listop);
+ o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
op_free(expr); /* oops, it's a while (0) */
op_free((OP*)loop);
- return Nullop; /* (listop already freed by newLOGOP) */
+ return Nullop; /* listop already freed by new_logop */
}
- ((LISTOP*)listop)->op_last->op_next = condop =
- (o == listop ? redo : LINKLIST(o));
+ if (listop)
+ ((LISTOP*)listop)->op_last->op_next = condop =
+ (o == listop ? redo : LINKLIST(o));
if (!next)
next = condop;
}
}
OP *
-#ifndef CAN_PROTOTYPE
-newFOROP(flags,label,forline,sv,expr,block,cont)
-I32 flags;
-char *label;
-line_t forline;
-OP* sv;
-OP* expr;
-OP*block;
-OP*cont;
-#else
newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
-#endif /* CAN_PROTOTYPE */
{
LOOP *loop;
OP *wop;
#endif
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
- expr = scalar(ref(expr, OP_ITER));
+ expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
+ iterflags |= OPf_STACKED;
+ }
+ else if (expr->op_type == OP_NULL &&
+ (expr->op_flags & OPf_KIDS) &&
+ ((BINOP*)expr)->op_first->op_type == OP_FLOP)
+ {
+ /* Basically turn for($x..$y) into the same as for($x,$y), but we
+ * set the STACKED flag to indicate that these values are to be
+ * treated as min/max values by 'pp_iterinit'.
+ */
+ UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
+ CONDOP* range = (CONDOP*) flip->op_first;
+ OP* left = range->op_first;
+ OP* right = left->op_sibling;
+ LISTOP* listop;
+
+ range->op_flags &= ~OPf_KIDS;
+ range->op_first = Nullop;
+
+ listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
+ listop->op_first->op_next = range->op_true;
+ left->op_next = range->op_false;
+ right->op_next = (OP*)listop;
+ listop->op_next = listop->op_first;
+
+ op_free(expr);
+ expr = (OP*)(listop);
+ null(expr);
iterflags |= OPf_STACKED;
}
+ else {
+ expr = mod(force_list(expr), OP_GREPSTART);
+ }
+
+
loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
- append_elem(OP_LIST, mod(force_list(expr), OP_GREPSTART),
- scalar(sv))));
+ append_elem(OP_LIST, expr, scalar(sv))));
assert(!loop->op_next);
Renew(loop, 1, LOOP);
loop->op_targ = padoff;
dTHR;
OP *o;
if (type != OP_GOTO || label->op_type == OP_CONST) {
- o = newPVOP(type, 0, savepv(
- label->op_type == OP_CONST
- ? SvPVx(((SVOP*)label)->op_sv, na)
- : "" ));
+ /* "last()" means "last" */
+ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
+ o = newOP(type, OPf_SPECIAL);
+ else {
+ o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
+ ? SvPVx(((SVOP*)label)->op_sv, na)
+ : ""));
+ }
op_free(label);
}
else {
if (CvPADLIST(cv)) {
/* may be during global destruction */
if (SvREFCNT(CvPADLIST(cv))) {
- I32 i = AvFILL(CvPADLIST(cv));
+ I32 i = AvFILLp(CvPADLIST(cv));
while (i >= 0) {
SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
SV* sv = svp ? *svp : Nullsv;
}
#ifdef DEBUG_CLOSURES
-static void
+STATIC void
cv_dump(cv)
CV* cv;
{
pname = AvARRAY(pad_name);
ppad = AvARRAY(pad);
- for (ix = 1; ix <= AvFILL(pad_name); ix++) {
+ for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
if (SvPOK(pname[ix]))
PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
ix, ppad[ix],
}
#endif /* DEBUG_CLOSURES */
-static CV *
+STATIC CV *
cv_clone2(CV *proto, CV *outside)
{
dTHR;
AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
SV** pname = AvARRAY(protopad_name);
SV** ppad = AvARRAY(protopad);
- I32 fname = AvFILL(protopad_name);
- I32 fpad = AvFILL(protopad);
+ I32 fname = AvFILLp(protopad_name);
+ I32 fpad = AvFILLp(protopad);
AV* comppadlist;
CV* cv;
av_store(comppadlist, 0, (SV*)comppad_name);
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(cv) = comppadlist;
- av_fill(comppad, AvFILL(protopad));
+ av_fill(comppad, AvFILLp(protopad));
curpad = AvARRAY(comppad);
av = newAV(); /* will be @_ */
SV *
cv_const_sv(CV *cv)
{
- OP *o;
- SV *sv;
-
if (!cv || !SvPOK(cv) || SvCUR(cv))
return Nullsv;
+ return op_const_sv(CvSTART(cv), cv);
+}
+
+SV *
+op_const_sv(OP *o, CV *cv)
+{
+ SV *sv = Nullsv;
+
+ if(!o)
+ return Nullsv;
+
+ if(o->op_type == OP_LINESEQ && cLISTOPo->op_first)
+ o = cLISTOPo->op_first->op_sibling;
- sv = Nullsv;
- for (o = CvSTART(cv); o; o = o->op_next) {
+ for (; o; o = o->op_next) {
OPCODE type = o->op_type;
-
+
+ if(sv && o->op_next == o)
+ return sv;
if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
continue;
if (type == OP_LEAVESUB || type == OP_RETURN)
return Nullsv;
if (type == OP_CONST)
sv = cSVOPo->op_sv;
- else if (type == OP_PADSV) {
+ else if (type == OP_PADSV && cv) {
AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
{
dTHR;
char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch;
- GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
+ GV *gv = gv_fetchpv(name ? name : "__ANON__",
+ GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV);
char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch;
- register CV *cv;
+ register CV *cv=0;
I32 ix;
if (o)
if (proto)
SAVEFREEOP(proto);
+ if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had
+ maximum a prototype before. */
+ if (SvTYPE(gv) > SVt_NULL) {
+ if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1))
+ warn("Runaway prototype");
+ cv_ckproto((CV*)gv, NULL, ps);
+ }
+ if (ps)
+ sv_setpv((SV*)gv, ps);
+ else
+ sv_setiv((SV*)gv, -1);
+ SvREFCNT_dec(compcv);
+ cv = compcv = NULL;
+ sub_generation++;
+ goto noblock;
+ }
+
if (!name || GvCVGEN(gv))
cv = Nullcv;
else if (cv = GvCV(gv)) {
/* already defined (or promised)? */
if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
SV* const_sv;
+ bool const_changed = TRUE;
if (!block) {
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(compcv);
goto done;
}
/* ahem, death to those who redefine active sort subs */
- if (curstack == sortstack && sortcop == CvSTART(cv))
+ if (curstackinfo->si_type == PERLSI_SORT && sortcop == CvSTART(cv))
croak("Can't redefine active sort subroutine %s", name);
- const_sv = cv_const_sv(cv);
- if (const_sv || dowarn) {
+ if(const_sv = cv_const_sv(cv))
+ const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
+ if ((const_sv && const_changed) || dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ && HvNAME(GvSTASH(CvGV(cv)))
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))),
+ "autouse"))) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
warn(const_sv ? "Constant subroutine %s redefined"
}
}
if (!block) {
+ noblock:
copline = NOLINE;
LEAVE_SCOPE(floor);
return cv;
}
- if (AvFILL(comppad_name) < AvFILL(comppad))
- av_store(comppad_name, AvFILL(comppad), Nullsv);
+ if (AvFILLp(comppad_name) < AvFILLp(comppad))
+ av_store(comppad_name, AvFILLp(comppad), Nullsv);
if (CvCLONE(cv)) {
SV **namep = AvARRAY(comppad_name);
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
SV *namesv;
if (SvIMMORTAL(curpad[ix]))
av_store(comppad, 0, (SV*)av);
AvFLAGS(av) = AVf_REIFY;
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
if (SvIMMORTAL(curpad[ix]))
continue;
if (!SvPADMY(curpad[ix]))
if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
&& (cv = GvCV(db_postponed))) {
dSP;
- PUSHMARK(sp);
+ PUSHMARK(SP);
XPUSHs(tmpstr);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
ENTER;
SAVESPTR(compiling.cop_filegv);
SAVEI16(compiling.cop_line);
- SAVEI32(perldb);
save_svref(&rs);
sv_setsv(rs, nrs);
return cv;
}
+void
+newCONSTSUB(HV *stash, char *name, SV *sv)
+{
+ dTHR;
+ U32 oldhints = hints;
+ HV *old_cop_stash = curcop->cop_stash;
+ HV *old_curstash = curstash;
+ line_t oldline = curcop->cop_line;
+ curcop->cop_line = copline;
+
+ hints &= ~HINT_BLOCK_SCOPE;
+ if(stash)
+ curstash = curcop->cop_stash = stash;
+
+ newSUB(
+ start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ hints = oldhints;
+ curcop->cop_stash = old_cop_stash;
+ curstash = old_curstash;
+ curcop->cop_line = oldline;
+}
+
CV *
-newXS(char *name, void (*subaddr) (CV *), char *filename)
+newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename)
{
dTHR;
GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
- if (dowarn) {
+ if (dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ && HvNAME(GvSTASH(CvGV(cv)))
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
warn("Subroutine %s redefined",name);
CvGV(cv) = (GV*)SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix]))
SvPADTMP_on(curpad[ix]);
}
return o;
}
else
- scalar(kid);
+ scalar((OP*)kid);
}
else {
op_free(o);
"Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
name, badthing);
}
- kid->op_type = OP_GV;
+ /*
+ * This is a little tricky. We only want to add the symbol if we
+ * didn't add it in the lexer. Otherwise we get duplicate strict
+ * warnings. But if we didn't add it in the lexer, we must at
+ * least pretend like we wanted to add it even if it existed before,
+ * or we get possible typo warnings. OPpCONST_ENTERED says
+ * whether the lexer already added THIS instance of this symbol.
+ */
iscv = (o->op_type == OP_RV2CV) * 2;
- for (gv = 0; !gv; iscv++) {
- /*
- * This is a little tricky. We only want to add the symbol if we
- * didn't add it in the lexer. Otherwise we get duplicate strict
- * warnings. But if we didn't add it in the lexer, we must at
- * least pretend like we wanted to add it even if it existed before,
- * or we get possible typo warnings. OPpCONST_ENTERED says
- * whether the lexer already added THIS instance of this symbol.
- */
+ do {
gv = gv_fetchpv(name,
iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
: o->op_type == OP_RV2HV
? SVt_PVHV
: SVt_PVGV);
+ } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
+ if (gv) {
+ kid->op_type = OP_GV;
+ SvREFCNT_dec(kid->op_sv);
+ kid->op_sv = SvREFCNT_inc(gv);
}
- SvREFCNT_dec(kid->op_sv);
- kid->op_sv = SvREFCNT_inc(gv);
}
return o;
}
if (o->op_flags & OPf_REF)
return o;
- if (o->op_flags & OPf_KIDS) {
+ if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
if (o->op_flags & OPf_KIDS) {
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_type == OP_CONST)
- fbm_compile(((SVOP*)kid)->op_sv);
+ fbm_compile(((SVOP*)kid)->op_sv, 0);
}
return ck_fun(o);
}
goto wrapref;
{
OP* kid = o2;
- o2 = newUNOP(OP_RV2GV, 0, kid);
- o2->op_sibling = kid->op_sibling;
+ OP* sib = kid->op_sibling;
kid->op_sibling = 0;
- prev->op_sibling = o;
+ o2 = newUNOP(OP_RV2GV, 0, kid);
+ o2->op_sibling = sib;
+ prev->op_sibling = o2;
}
goto wrapref;
case '\\':
wrapref:
{
OP* kid = o2;
- o2 = newUNOP(OP_REFGEN, 0, kid);
- o2->op_sibling = kid->op_sibling;
+ OP* sib = kid->op_sibling;
kid->op_sibling = 0;
+ o2 = newUNOP(OP_REFGEN, 0, kid);
+ o2->op_sibling = sib;
prev->op_sibling = o2;
}
break;
goto nothin;
case OP_NULL:
if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
- curcop = ((COP*)op);
+ curcop = ((COP*)o);
goto nothin;
case OP_SCALAR:
case OP_LINESEQ:
case OP_PADAV:
if (o->op_next->op_type == OP_RV2AV
- && (o->op_next->op_flags && OPf_REF))
+ && (o->op_next->op_flags & OPf_REF))
{
null(o->op_next);
o->op_next = o->op_next->op_next;
case OP_PADHV:
if (o->op_next->op_type == OP_RV2HV
- && (o->op_next->op_flags && OPf_REF))
+ && (o->op_next->op_flags & OPf_REF))
{
null(o->op_next);
o->op_next = o->op_next->op_next;
case OP_AND:
case OP_OR:
o->op_seq = op_seqmax++;
+ while (cLOGOP->op_other->op_type == OP_NULL)
+ cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other);
break;
peep(cLOOP->op_lastop);
break;
+ case OP_QR:
case OP_MATCH:
case OP_SUBST:
o->op_seq = op_seqmax++;
o->op_seq = op_seqmax++;
if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) {
if (o->op_next->op_sibling &&
+ o->op_next->op_sibling->op_type != OP_EXIT &&
+ o->op_next->op_sibling->op_type != OP_WARN &&
o->op_next->op_sibling->op_type != OP_DIE) {
line_t oldline = curcop->cop_line;
https://perl5.git.perl.org / perl5.git / blobdiff