/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
PADOFFSET
Perl_allocmy(pTHX_ char *name)
{
+ dVAR;
PADOFFSET off;
+ const bool is_our = (PL_in_my == KEY_our);
/* complain about "my $<special_var>" etc etc */
if (*name &&
- !(PL_in_my == KEY_our ||
+ !(is_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
(name[1] == '_' && (*name == '$' || name[2]))))
}
/* check for duplicate declaration */
- pad_check_dup(name,
- (bool)(PL_in_my == KEY_our),
- (PL_curstash ? PL_curstash : PL_defstash)
- );
+ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
if (PL_in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
- name, PL_in_my == KEY_our ? "our" : "my"));
+ name, is_our ? "our" : "my"));
}
/* allocate a spare slot and store the name in that slot */
off = pad_add_name(name,
PL_in_my_stash,
- (PL_in_my == KEY_our
+ (is_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
OP *
Perl_linklist(pTHX_ OP *o)
{
+ OP *first;
if (o->op_next)
return o->op_next;
/* establish postfix order */
- if (cUNOPo->op_first) {
+ first = cUNOPo->op_first;
+ if (first) {
register OP *kid;
- o->op_next = LINKLIST(cUNOPo->op_first);
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling)
+ o->op_next = LINKLIST(first);
+ kid = first;
+ for (;;) {
+ if (kid->op_sibling) {
kid->op_next = LINKLIST(kid->op_sibling);
- else
+ kid = kid->op_sibling;
+ } else {
kid->op_next = o;
+ break;
+ }
}
}
else
STATIC OP *
S_scalarboolean(pTHX_ OP *o)
{
+ dVAR;
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
built upon these three nroff macros being used in
void context. The pink camel has the details in
the script wrapman near page 319. */
- if (strnEQ(SvPVX_const(sv), "di", 2) ||
- strnEQ(SvPVX_const(sv), "ds", 2) ||
- strnEQ(SvPVX_const(sv), "ig", 2))
+ const char * const maybe_macro = SvPVX_const(sv);
+ if (strnEQ(maybe_macro, "di", 2) ||
+ strnEQ(maybe_macro, "ds", 2) ||
+ strnEQ(maybe_macro, "ig", 2))
useless = 0;
}
}
OP *
Perl_scalarseq(pTHX_ OP *o)
{
+ dVAR;
if (o) {
if (o->op_type == OP_LINESEQ ||
o->op_type == OP_SCOPE ||
case OP_CONST:
if (!(o->op_private & (OPpCONST_ARYBASE)))
goto nomod;
+ localize = 0;
if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
PL_eval_start = 0;
/* FALL THROUGH */
default:
nomod:
- /* grep, foreach, subcalls, refgen, m//g */
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
- || type == OP_MATCH)
+ /* grep, foreach, subcalls, refgen */
+ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
+ dVAR;
OP *rop;
/* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
if (for_my) {
/* Don't force the C<use> if we don't need it. */
- SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
- sizeof(ATTRSMODULE_PM)-1, 0);
+ SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
if (svp && *svp != &PL_sv_undef)
; /* already in %INC */
else
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv);
+ newSVpvs(ATTRSMODULE), NULL);
}
else {
Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv,
+ newSVpvs(ATTRSMODULE),
+ NULL,
prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0, stashsv),
prepend_elem(OP_LIST,
STATIC void
S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
{
+ dVAR;
OP *pack, *imop, *arg;
SV *meth, *stashsv;
apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
/* Need package name for method call. */
- pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
+ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
/* Build up the real arg-list. */
stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
dup_attrlist(attrs)));
/* Fake up a method call to import */
- meth = newSVpvn_share("import", 6, 0);
+ meth = newSVpvs_share("import");
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
}
Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ newSVpvs(ATTRSMODULE),
Nullsv, prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
prepend_elem(OP_LIST,
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
+ dVAR;
I32 type;
if (!o || PL_error_count)
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
+ dVAR;
OP *rops;
int maybe_scalar = 0;
}
if (!(right->op_flags & OPf_STACKED) && ismatchop) {
right->op_flags |= OPf_STACKED;
- /* s/// and tr/// modify their arg.
- * m//g also indirectly modifies the arg by setting pos magic on it */
- if ( (right->op_type == OP_MATCH &&
- (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
- || (right->op_type == OP_SUBST)
- || (right->op_type == OP_TRANS &&
- ! (right->op_private & OPpTRANS_IDENTICAL))
- )
+ if (right->op_type != OP_MATCH &&
+ ! (right->op_type == OP_TRANS &&
+ right->op_private & OPpTRANS_IDENTICAL))
left = mod(left, right->op_type);
if (right->op_type == OP_TRANS)
o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
int
Perl_block_start(pTHX_ int full)
{
+ dVAR;
const int retval = PL_savestack_ix;
pad_block_start(full);
SAVEHINTS();
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
+ dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* const retval = scalarseq(seq);
LEAVE_SCOPE(floor);
STATIC OP *
S_newDEFSVOP(pTHX)
{
+ dVAR;
const I32 offset = pad_findmy("$_");
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
void
Perl_newPROG(pTHX_ OP *o)
{
+ dVAR;
if (PL_in_eval) {
if (PL_eval_root)
return;
OP *
Perl_localize(pTHX_ OP *o, I32 lex)
{
+ dVAR;
if (o->op_flags & OPf_PARENS)
/* [perl #17376]: this appears to be premature, and results in code such as
C< our(%x); > executing in list mode rather than void mode */
Perl_jmaybe(pTHX_ OP *o)
{
if (o->op_type == OP_LIST) {
- OP *o2;
- o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
+ OP * const o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV)));
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
OP *
Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
+ dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
SV * const rstr = ((SVOP*)repl)->op_sv;
STRLEN tlen;
if (expr->op_type == OP_CONST) {
STRLEN plen;
- SV *pat = ((SVOP*)expr)->op_sv;
+ SV * const pat = ((SVOP*)expr)->op_sv;
const char *p = SvPV_const(pat, plen);
if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
U32 was_readonly = SvREADONLY(pat);
if (repl) {
OP *curop;
if (pm->op_pmflags & PMf_EVAL) {
- curop = 0;
+ curop = NULL;
if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
- GV *gv = cGVOPx_gv(curop);
+ GV * const gv = cGVOPx_gv(curop);
repl_has_vars = 1;
if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
break;
void
Perl_package(pTHX_ OP *o)
{
+ dVAR;
const char *name;
STRLEN len;
void
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
+ dVAR;
OP *pack;
OP *imop;
OP *veop;
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to VERSION */
- meth = newSVpvn_share("VERSION", 7, 0);
+ meth = newSVpvs_share("VERSION");
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(version)),
/* Fake up a method call to import/unimport */
meth = aver
- ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
+ ? newSVpvs_share("import") : newSVpvs_share("unimport");
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
- newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
+ newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
Nullop,
Nullop,
append_elem(OP_LINESEQ,
void
Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
+ dVAR;
OP *veop, *imop;
OP * const modname = newSVOP(OP_CONST, 0, name);
OP *
Perl_dofile(pTHX_ OP *term, I32 force_builtin)
{
+ dVAR;
OP *doop;
GV *gv = Nullgv;
if (!force_builtin) {
gv = gv_fetchpv("do", 0, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
+ GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
gv = gvp ? *gvp : Nullgv;
}
}
OP *
Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
{
+ dVAR;
OP *o;
if (optype) {
OP *
Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
{
+ dVAR;
OP* listop;
OP* o;
const bool once = block && block->op_flags & OPf_SPECIAL &&
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
+ dVAR;
OP *o;
if (type != OP_GOTO || label->op_type == OP_CONST) {
I32 enter_opcode, I32 leave_opcode,
PADOFFSET entertarg)
{
+ dVAR;
LOGOP *enterop;
OP *o;
bool
S_looks_like_bool(pTHX_ OP *o)
{
+ dVAR;
switch(o->op_type) {
case OP_OR:
return looks_like_bool(cLOGOPo->op_first);
OP *
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
+ dVAR;
assert( cond );
return newGIVWHENOP(
ref_array_or_hash(cond),
SV *
Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
{
+ dVAR;
SV *sv = Nullsv;
if (!o)
const char * const tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV * const sv = NEWSV(0,0);
+ SV * const sv = newSV(0);
SV * const tmpstr = sv_newmortal();
GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
HV *hv;
CV *
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
+ dVAR;
GV * const gv = gv_fetchpv(name ? name :
(PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
GV_ADDMULTI, SVt_PVCV);
if (cv) /* must reuse cv if autoloaded */
cv_undef(cv);
else {
- cv = (CV*)NEWSV(1105,0);
+ cv = (CV*)newSV(0);
sv_upgrade((SV *)cv, SVt_PVCV);
if (name) {
GvCV(gv) = cv;
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
+ dVAR;
register CV *cv;
GV * const gv = o
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
+ dVAR;
#define OP_IS_NUMCOMPARE(op) \
((op) == OP_LT || (op) == OP_I_LT || \
(op) == OP_GT || (op) == OP_I_GT || \
OP *
Perl_ck_eof(pTHX_ OP *o)
{
+ dVAR;
const I32 type = o->op_type;
if (o->op_flags & OPf_KIDS) {
#ifdef VMS
HV * const table = GvHV(PL_hintgv);
if (table) {
- SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
+ SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
OP *
Perl_ck_exists(pTHX_ OP *o)
{
+ dVAR;
o = ck_fun(o);
if (o->op_flags & OPf_KIDS) {
OP * const kid = cUNOPo->op_first;
OP *
Perl_ck_fun(pTHX_ OP *o)
{
+ dVAR;
const int type = o->op_type;
register I32 oa = PL_opargs[type] >> OASHIFT;
|| kid->op_type == OP_HELEM)
{
OP *op = ((BINOP*)kid)->op_first;
- name = 0;
+ name = NULL;
if (op) {
SV *tmpstr = Nullsv;
const char * const a =
OP *
Perl_ck_smartmatch(pTHX_ OP *o)
{
+ dVAR;
if (0 == (o->op_flags & OPf_SPECIAL)) {
OP *first = cBINOPo->op_first;
OP *second = first->op_sibling;
OP *
Perl_ck_match(pTHX_ OP *o)
{
+ dVAR;
if (o->op_type != OP_QR && PL_compcv) {
const I32 offset = pad_findmy("$_");
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONST) {
SV* sv = kSVOP->op_sv;
- if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
+ const char * const method = SvPVX_const(sv);
+ if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
+ sv = newSVpvn_share(method, SvCUR(sv), 0);
}
else {
kSVOP->op_sv = Nullsv;
OP *
Perl_ck_open(pTHX_ OP *o)
{
+ dVAR;
HV * const table = GvHV(PL_hintgv);
if (table) {
- SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
+ SV **svp = hv_fetchs(table, "open_IN", FALSE);
if (svp && *svp) {
const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_CRLF;
}
- svp = hv_fetch(table, "open_OUT", 8, FALSE);
+ svp = hv_fetchs(table, "open_OUT", FALSE);
if (svp && *svp) {
const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
OP *
Perl_ck_require(pTHX_ OP *o)
{
+ dVAR;
GV* gv = Nullgv;
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
/* handle override, if any */
gv = gv_fetchpv("require", 0, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
+ GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
gv = gvp ? *gvp : Nullgv;
}
}
OP *
Perl_ck_return(pTHX_ OP *o)
{
+ dVAR;
if (CvLVALUE(PL_compcv)) {
OP *kid;
for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
OP *
Perl_ck_shift(pTHX_ OP *o)
{
+ dVAR;
const I32 type = o->op_type;
if (!(o->op_flags & OPf_KIDS)) {
OP *
Perl_ck_sort(pTHX_ OP *o)
{
+ dVAR;
OP *firstkid;
if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
{
- HV *hinthv = GvHV(PL_hintgv);
+ HV * const hinthv = GvHV(PL_hintgv);
if (hinthv) {
- SV **svp = hv_fetch(hinthv, "sort", 4, 0);
+ SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (svp) {
- I32 sorthints = (I32)SvIV(*svp);
+ const I32 sorthints = (I32)SvIV(*svp);
if ((sorthints & HINT_SORT_QUICKSORT) != 0)
o->op_private |= OPpSORT_QSORT;
if ((sorthints & HINT_SORT_STABLE) != 0)
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
+ dVAR;
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int descending;
OP *
Perl_ck_subr(pTHX_ OP *o)
{
+ dVAR;
OP *prev = ((cUNOPo->op_first->op_sibling)
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
key = SvPV_const(*svp, keylen);
lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
/* Again guessing that the pushmark can be jumped over.... */
char*
Perl_custom_op_name(pTHX_ const OP* o)
{
+ dVAR;
const IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
HE* he;
char*
Perl_custom_op_desc(pTHX_ const OP* o)
{
+ dVAR;
const IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
HE* he;
static void
const_sv_xsub(pTHX_ CV* cv)
{
+ dVAR;
dXSARGS;
if (items != 0) {
#if 0
projects / p5sagit/p5-mst-13.2.git / blobdiff