/* #define PL_OP_SLAB_ALLOC */
-/* XXXXXX testing */
-#ifdef USE_ITHREADS
-# define OP_REFCNT_LOCK NOOP
-# define OP_REFCNT_UNLOCK NOOP
-# define OpREFCNT_set(o,n) ((o)->op_targ = (n))
-# define OpREFCNT_dec(o) (--(o)->op_targ)
-#else
-# define OP_REFCNT_LOCK NOOP
-# define OP_REFCNT_UNLOCK NOOP
-# define OpREFCNT_set(o,n) NOOP
-# define OpREFCNT_dec(o) 0
-#endif
-
#ifdef PL_OP_SLAB_ALLOC
#define SLAB_SIZE 8192
static char *PL_OpPtr = NULL;
PADOFFSET off;
SV *sv;
- if (!(
- PL_in_my == KEY_our ||
- isALPHA(name[1]) ||
- (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
- name[1] == '_' && (int)strlen(name) > 2 ))
+ if (!(PL_in_my == KEY_our ||
+ isALPHA(name[1]) ||
+ (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
+ (name[1] == '_' && (int)strlen(name) > 2)))
{
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
/* 1999-02-27 mjd@plover.com */
}
}
if (PL_in_my == KEY_our) {
- while (off >= 0 && off <= top) {
+ do {
if ((sv = svp[off])
&& sv != &PL_sv_undef
&& ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
"(Did you mean \"local\" instead of \"our\"?)\n");
break;
}
- --off;
- }
+ } while ( off-- > 0 );
}
}
off = pad_alloc(OP_PADSV, SVs_PADMY);
}
if (PL_in_my == KEY_our) {
(void)SvUPGRADE(sv, SVt_PVGV);
- GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? PL_curstash : PL_defstash);
+ GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
SvFLAGS(sv) |= SVpad_OUR;
}
av_store(PL_comppad_name, off, sv);
if (CxREALEVAL(cx))
saweval = i;
break;
+ case OP_DOFILE:
case OP_REQUIRE:
- /* require must have its own scope */
+ /* require/do must have their own scope */
return 0;
}
break;
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
scalar(kid);
- while (kid = kid->op_sibling) {
+ while ((kid = kid->op_sibling)) {
if (kid->op_sibling)
scalarvoid(kid);
else
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
list(kid);
- while (kid = kid->op_sibling) {
+ while ((kid = kid->op_sibling)) {
if (kid->op_sibling)
scalarvoid(kid);
else
{
dTHR;
OP *kid;
- SV *sv;
STRLEN n_a;
if (!o || PL_error_count)
STATIC void
S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
{
- OP *modname; /* for 'use' */
SV *stashsv;
/* fake up C<use attributes $pkg,$rv,@attrs> */
stashsv = newSVpv(HvNAME(stash), 0);
else
stashsv = &PL_sv_no;
+
#define ATTRSMODULE "attributes"
- modname = newSVOP(OP_CONST, 0,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
- modname->op_private |= OPpCONST_BARE;
- /* that flag is required to make 'use' work right */
- utilize(1, start_subparse(FALSE, 0),
- Nullop, /* version */
- modname,
- prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, stashsv),
- prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, newRV(target)),
- dup_attrlist(attrs))));
+
+ Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ Nullsv,
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newRV(target)),
+ dup_attrlist(attrs))));
LEAVE;
}
if (!last)
return first;
- if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS)
- return newLISTOP(type, 0, first, last);
+ if (first->op_type != type
+ || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
+ {
+ return newLISTOP(type, 0, first, last);
+ }
if (first->op_flags & OPf_KIDS)
((LISTOP*)first)->op_last->op_sibling = last;
I32 grows = 0;
I32 havefinal = 0;
U32 final;
- HV *hv;
I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
{
OP *pack;
- OP *meth;
OP *rqop;
OP *imop;
OP *veop;
/* Fake up a method call to VERSION */
meth = newSVpvn("VERSION",7);
sv_upgrade(meth, SVt_PVIV);
- SvIOK_on(meth);
+ (void)SvIOK_on(meth);
PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
/* Fake up a method call to import/unimport */
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
sv_upgrade(meth, SVt_PVIV);
- SvIOK_on(meth);
+ (void)SvIOK_on(meth);
PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
PL_expect = XSTATE;
}
+void
+Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
+{
+ va_list args;
+ va_start(args, ver);
+ vload_module(flags, name, ver, &args);
+ va_end(args);
+}
+
+#ifdef PERL_IMPLICIT_CONTEXT
+void
+Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, ver);
+ vload_module(flags, name, ver, &args);
+ va_end(args);
+}
+#endif
+
+void
+Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
+{
+ OP *modname, *veop, *imop;
+
+ modname = newSVOP(OP_CONST, 0, name);
+ modname->op_private |= OPpCONST_BARE;
+ if (ver) {
+ veop = newSVOP(OP_CONST, 0, ver);
+ }
+ else
+ veop = Nullop;
+ if (flags & PERL_LOADMOD_NOIMPORT) {
+ imop = sawparens(newNULLLIST());
+ }
+ else if (flags & PERL_LOADMOD_IMPORT_OPS) {
+ imop = va_arg(*args, OP*);
+ }
+ else {
+ SV *sv;
+ imop = Nullop;
+ sv = va_arg(*args, SV*);
+ while (sv) {
+ imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
+ sv = va_arg(*args, SV*);
+ }
+ }
+ utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+ veop, modname, imop);
+}
+
OP *
Perl_dofile(pTHX_ OP *term)
{
if (list_assignment(left)) {
dTHR;
+ OP *curop;
+
PL_modcount = 0;
PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
left = mod(left, OP_AASSIGN);
op_free(right);
return Nullop;
}
- o = newBINOP(OP_AASSIGN, flags,
- list(force_list(right)),
- list(force_list(left)) );
+ curop = list(force_list(left));
+ o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = 0 | (flags >> 8);
+ for (curop = ((LISTOP*)curop)->op_first;
+ curop; curop = curop->op_sibling)
+ {
+ if (curop->op_type == OP_RV2HV &&
+ ((UNOP*)curop)->op_first->op_type != OP_GV) {
+ o->op_private |= OPpASSIGN_HASH;
+ break;
+ }
+ }
if (!(left->op_private & OPpLVAL_INTRO)) {
- OP *curop;
OP *lastop = o;
PL_generation++;
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
lastop = curop;
}
if (curop != o)
- o->op_private = OPpASSIGN_COMMON;
+ o->op_private |= OPpASSIGN_COMMON;
}
if (right && right->op_type == OP_SPLIT) {
OP* tmpop;
OP *listop;
OP *o;
OP *condop;
+ U8 loopflags = 0;
if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
block = scope(block);
}
- if (cont)
+ if (cont) {
next = LINKLIST(cont);
+ loopflags |= OPpLOOP_CONTINUE;
+ }
if (expr) {
cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
if ((line_t)whileline != NOLINE) {
loop->op_redoop = redo;
loop->op_lastop = o;
+ o->op_private |= loopflags;
if (next)
loop->op_nextop = next;
Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
{
LOOP *loop;
- LOOP *tmp;
OP *wop;
int padoff = 0;
I32 iterflags = 0;
append_elem(OP_LIST, expr, scalar(sv))));
assert(!loop->op_next);
#ifdef PL_OP_SLAB_ALLOC
- NewOp(1234,tmp,1,LOOP);
- Copy(loop,tmp,1,LOOP);
- loop = tmp;
+ {
+ LOOP *tmp;
+ NewOp(1234,tmp,1,LOOP);
+ Copy(loop,tmp,1,LOOP);
+ loop = tmp;
+ }
#else
Renew(loop, 1, LOOP);
#endif
if (!name || GvCVGEN(gv))
cv = Nullcv;
- else if (cv = GvCV(gv)) {
+ else if ((cv = GvCV(gv))) {
cv_ckproto(cv, gv, ps);
/* already defined (or promised)? */
if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
if (!block)
goto withattrs;
- if (const_sv = cv_const_sv(cv))
+ if ((const_sv = cv_const_sv(cv)))
const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
if ((const_sv || const_changed) && ckWARN(WARN_REDEFINE))
{
GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
CV *pcv;
HV *hv;
- char *t;
Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
CopFILE(PL_curcop),
GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
register CV *cv;
- if (cv = (name ? GvCV(gv) : Nullcv)) {
+ if ((cv = (name ? GvCV(gv) : Nullcv))) {
if (GvCVGEN(gv)) {
/* just a cached method */
SvREFCNT_dec(cv);
name = "STDOUT";
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
GvMULTI_on(gv);
- if (cv = GvFORM(gv)) {
+ if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
line_t oldline = CopLINE(PL_curcop);
tokid = &cLISTOPo->op_first;
kid = cLISTOPo->op_first;
if (kid->op_type == OP_PUSHMARK ||
- kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)
+ (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
{
tokid = &kid->op_sibling;
kid = kid->op_sibling;
SV *namesv;
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
namesv = PL_curpad[targ];
- SvUPGRADE(namesv, SVt_PV);
+ (void)SvUPGRADE(namesv, SVt_PV);
if (*name != '$')
sv_setpvn(namesv, "$", 1);
sv_catpvn(namesv, name, len);
#if !defined(PERL_EXTERNAL_GLOB)
/* XXX this can be tightened up and made more failsafe. */
if (!gv) {
- OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10));
- modname->op_private |= OPpCONST_BARE;
ENTER;
- utilize(1, start_subparse(FALSE, 0), Nullop, modname,
- newSVOP(OP_CONST, 0, newSVpvn(":globally", 9)));
+ Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
+ /* null-terminated import list */
+ newSVpvn(":globally", 9), Nullsv);
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
LEAVE;
}
SV* sv = kSVOP->op_sv;
if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
OP *cmop;
- sv_upgrade(sv, SVt_PVIV);
- SvIOK_on(sv);
+ (void)SvUPGRADE(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv));
cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
kSVOP->op_sv = Nullsv;
}
OP *
+Perl_ck_open(pTHX_ OP *o)
+{
+ HV *table = GvHV(PL_hintgv);
+ if (table) {
+ SV **svp;
+ I32 mode;
+ svp = hv_fetch(table, "open_IN", 7, FALSE);
+ if (svp && *svp) {
+ mode = mode_from_discipline(*svp);
+ if (mode & O_BINARY)
+ o->op_private |= OPpOPEN_IN_RAW;
+ else if (mode & O_TEXT)
+ o->op_private |= OPpOPEN_IN_CRLF;
+ }
+
+ svp = hv_fetch(table, "open_OUT", 8, FALSE);
+ if (svp && *svp) {
+ mode = mode_from_discipline(*svp);
+ if (mode & O_BINARY)
+ o->op_private |= OPpOPEN_OUT_RAW;
+ else if (mode & O_TEXT)
+ o->op_private |= OPpOPEN_OUT_CRLF;
+ }
+ }
+ if (o->op_type == OP_BACKTICK)
+ return o;
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_repeat(pTHX_ OP *o)
{
if (cBINOPo->op_first->op_flags & OPf_PARENS) {
--SvCUR(kid->op_sv);
}
}
- sv_catpvn(kid->op_sv, ".pm", 3);
+ if (SvREADONLY(kid->op_sv)) {
+ SvREADONLY_off(kid->op_sv);
+ sv_catpvn(kid->op_sv, ".pm", 3);
+ SvREADONLY_on(kid->op_sv);
+ }
+ else
+ sv_catpvn(kid->op_sv, ".pm", 3);
}
}
return ck_fun(o);
o->op_targ = ix;
}
#endif
- /* FALL THROUGH */
- case OP_UC:
- case OP_UCFIRST:
- case OP_LC:
- case OP_LCFIRST:
+ o->op_seq = PL_op_seqmax++;
+ break;
+
case OP_CONCAT:
- case OP_JOIN:
- case OP_QUOTEMETA:
if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
if (o->op_next->op_private & OPpTARGET_MY) {
if (o->op_flags & OPf_STACKED) /* chained concats */
goto ignore_optimization;
else {
+ /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
o->op_targ = o->op_next->op_targ;
o->op_next->op_targ = 0;
o->op_private |= OPpTARGET_MY;
projects / p5sagit/p5-mst-13.2.git / blobdiff