/* #define PL_OP_SLAB_ALLOC */
-#ifdef PL_OP_SLAB_ALLOC
+#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
#define SLAB_SIZE 8192
-static char *PL_OpPtr = NULL;
-static int PL_OpSpace = 0;
+static char *PL_OpPtr = NULL; /* XXX threadead */
+static int PL_OpSpace = 0; /* XXX threadead */
#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
var = (type *)(PL_OpPtr -= c*sizeof(type)); \
else \
goto clear_pmop;
case OP_PUSHRE:
#ifdef USE_ITHREADS
- if ((PADOFFSET)cPMOPo->op_pmreplroot) {
+ if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
if (PL_curpad) {
- GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
- pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
+ GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
+ pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
/* No GvIN_PAD_off(gv) here, because other references may still
* exist on the pad */
SvREFCNT_dec(gv);
}
WITH_THR(PL_curcop = &PL_compiling);
break;
+ case OP_SORT:
+ if (ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
}
return o;
}
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
- "args: type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "args: type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
kid = kLISTOP->op_first;
skip_kids:
while (kid->op_sibling)
if (kid->op_type != OP_RV2CV)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
- "entry via type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "entry via type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
kid->op_private |= OPpLVAL_INTRO;
break; /* Postpone until runtime */
}
if (kid->op_type == OP_NULL)
Perl_croak(aTHX_
"Unexpected constant lvalue entersub "
- "entry via type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "entry via type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
if (kid->op_type != OP_GV) {
/* Restore RV2CV to check lvalueness */
restore_2cv:
goto nomod;
break; /* mod()ing was handled by ck_return() */
}
+
+ /* [20011101.069] File test operators interpret OPf_REF to mean that
+ their argument is a filehandle; thus \stat(".") should not set
+ it. AMS 20011102 */
+ if (type == OP_REFGEN &&
+ PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
+ return o;
+
if (type != OP_LEAVESUBLV)
o->op_flags |= OPf_MOD;
/* Fake up a method call to import/unimport */
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
- sv_upgrade(meth, SVt_PVIV);
+ (void)SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
else if (curop->op_type == OP_PUSHRE) {
if (((PMOP*)curop)->op_pmreplroot) {
#ifdef USE_ITHREADS
- GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
+ GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
#else
GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
#endif
tmpop = ((UNOP*)left)->op_first;
if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
+ pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
- (void)SvIOK_on(*svp);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
SvIVX(*svp) = PTR2IV(cop);
- }
+ }
}
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
* CV, they don't hold a refcount on the outside CV. This avoids
* the refcount loop between the outer CV (which keeps a refcount to
* the closure prototype in the pad entry for pp_anoncode()) and the
- * closure prototype, and the ensuing memory leak. This does not
- * apply to closures generated within eval"", since eval"" CVs are
- * ephemeral. --GSAR */
- if (!CvANON(cv) || CvCLONED(cv)
- || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
- && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
- {
+ * closure prototype, and the ensuing memory leak. --GSAR */
+ if (!CvANON(cv) || CvCLONED(cv))
SvREFCNT_dec(CvOUTSIDE(cv));
- }
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
}
}
- /* If a potential closure prototype, don't keep a refcount on
- * outer CV, unless the latter happens to be a passing eval"".
+ /* If a potential closure prototype, don't keep a refcount on outer CV.
* This is okay as the lifetime of the prototype is tied to the
* lifetime of the outer CV. Avoids memory leak due to reference
* loop. --GSAR */
- if (!name && CvOUTSIDE(cv)
- && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
- && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
- {
+ if (!name)
SvREFCNT_dec(CvOUTSIDE(cv));
- }
if (name || aname) {
char *s;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
- save_svref(&PL_rs);
- sv_setsv(PL_rs, PL_nrs);
if (!PL_beginav)
PL_beginav = newAV();
}
OP *
+Perl_ck_die(pTHX_ OP *o)
+{
+#ifdef VMS
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
+#endif
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_eof(pTHX_ OP *o)
{
I32 type = o->op_type;
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
#endif
return ck_fun(o);
}
GV *namegv = 0;
int optional = 0;
I32 arg = 0;
+ I32 contextclass = 0;
+ char *e = 0;
STRLEN n_a;
o->op_private |= OPpENTERSUB_HASTARG;
}
scalar(o2);
break;
+ case '[': case ']':
+ goto oops;
+ break;
case '\\':
proto++;
arg++;
+ again:
switch (*proto++) {
+ case '[':
+ if (contextclass++ == 0) {
+ e = strchr(proto, ']');
+ if (!e || e == proto)
+ goto oops;
+ }
+ else
+ goto oops;
+ goto again;
+ break;
+ case ']':
+ if (contextclass)
+ contextclass = 0;
+ else
+ goto oops;
+ break;
case '*':
- if (o2->op_type != OP_RV2GV)
- bad_type(arg, "symbol", gv_ename(namegv), o2);
- goto wrapref;
+ if (o2->op_type == OP_RV2GV)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "symbol", gv_ename(namegv), o2);
+ break;
case '&':
- if (o2->op_type != OP_ENTERSUB)
- bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
- goto wrapref;
+ if (o2->op_type == OP_ENTERSUB)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
+ break;
case '$':
- if (o2->op_type != OP_RV2SV
- && o2->op_type != OP_PADSV
- && o2->op_type != OP_HELEM
- && o2->op_type != OP_AELEM
- && o2->op_type != OP_THREADSV)
- {
+ if (o2->op_type == OP_RV2SV ||
+ o2->op_type == OP_PADSV ||
+ o2->op_type == OP_HELEM ||
+ o2->op_type == OP_AELEM ||
+ o2->op_type == OP_THREADSV)
+ goto wrapref;
+ if (!contextclass)
bad_type(arg, "scalar", gv_ename(namegv), o2);
- }
- goto wrapref;
+ break;
case '@':
- if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
+ if (o2->op_type == OP_RV2AV ||
+ o2->op_type == OP_PADAV)
+ goto wrapref;
+ if (!contextclass)
bad_type(arg, "array", gv_ename(namegv), o2);
- goto wrapref;
+ break;
case '%':
- if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
- bad_type(arg, "hash", gv_ename(namegv), o2);
- wrapref:
+ if (o2->op_type == OP_RV2HV ||
+ o2->op_type == OP_PADHV)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "hash", gv_ename(namegv), o2);
+ break;
+ wrapref:
{
OP* kid = o2;
OP* sib = kid->op_sibling;
o2->op_sibling = sib;
prev->op_sibling = o2;
}
+ if (contextclass && e) {
+ proto = e + 1;
+ contextclass = 0;
+ }
break;
default: goto oops;
}
+ if (contextclass)
+ goto again;
break;
case ' ':
proto++;
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %s",
- gv_ename(namegv), SvPV((SV*)cv, n_a));
+ gv_ename(namegv), SvPV((SV*)cv, n_a));
}
}
else
&& o->op_next->op_next->op_type == OP_CONCAT
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
- /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
- o->op_next->op_type = OP_RCATLINE;
- o->op_next->op_flags |= OPf_STACKED;
+ /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
+ o->op_type = OP_RCATLINE;
+ o->op_flags |= OPf_STACKED;
+ o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
op_null(o->op_next->op_next);
+ op_null(o->op_next);
}
o->op_seq = PL_op_seqmax++;
LEAVE;
}
-#ifdef PERL_CUSTOM_OPS
-char* custom_op_name(pTHX_ OP* o)
+
+
+char* Perl_custom_op_name(pTHX_ OP* o)
{
IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
return SvPV_nolen(HeVAL(he));
}
-char* custom_op_desc(pTHX_ OP* o)
+char* Perl_custom_op_desc(pTHX_ OP* o)
{
IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
return SvPV_nolen(HeVAL(he));
}
-#endif
+
#include "XSUB.h"
projects / p5sagit/p5-mst-13.2.git / blobdiff