/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
return; /* various ok barewords are hidden in extra OP_NULL */
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
- (void*)cSVOPo_sv));
+ SVfARG(cSVOPo_sv)));
}
/* "register" allocation */
return off;
}
+/* free the body of an op without examining its contents.
+ * Always use this rather than FreeOp directly */
+
+void
+S_op_destroy(pTHX_ OP *o)
+{
+ if (o->op_latefree) {
+ o->op_latefreed = 1;
+ return;
+ }
+ FreeOp(o);
+}
+
+
/* Destructor */
void
if (!o || o->op_static)
return;
+ if (o->op_latefreed) {
+ if (o->op_latefree)
+ return;
+ goto do_free;
+ }
type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
cop_free((COP*)o);
op_clear(o);
+ if (o->op_latefree) {
+ o->op_latefreed = 1;
+ return;
+ }
+ do_free:
FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
/* FALL THROUGH */
case OP_TRANS:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+#ifdef USE_ITHREADS
+ if (cPADOPo->op_padix > 0) {
+ pad_swipe(cPADOPo->op_padix, TRUE);
+ cPADOPo->op_padix = 0;
+ }
+#else
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
+#endif
}
else {
- Safefree(cPVOPo->op_pv);
+ PerlMemShared_free(cPVOPo->op_pv);
cPVOPo->op_pv = NULL;
}
break;
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ CopLABEL_free(cop);
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
}
break;
- case OP_THREADSV:
- o->op_flags |= OPf_MOD; /* XXX ??? */
- break;
-
case OP_RV2AV:
case OP_RV2HV:
if (set_op_ref)
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
- yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
+ yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
} else if (attrs) {
if (o->op_type == OP_STUB) {
PL_comppad_name = 0;
PL_compcv = 0;
- FreeOp(o);
+ S_op_destroy(aTHX_ o);
return;
}
PL_main_root = scope(sawparens(scalarvoid(o)));
/* Register with debugger */
if (PERLDB_INTER) {
- CV * const cv = get_cv("DB::postponed", FALSE);
+ CV * const cv
+ = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
if (cv) {
dSP;
PUSHMARK(SP);
register OP *curop;
OP *newop;
VOL I32 type = o->op_type;
- VOL SV *sv = NULL;
+ SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
OP *old_next;
last->op_madprop = 0;
#endif
- FreeOp(last);
+ S_op_destroy(aTHX_ (OP*)last);
return (OP*)first;
}
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags = (U8)flags;
+ o->op_latefree = 0;
+ o->op_latefreed = 0;
+ o->op_attached = 0;
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
{
dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
- SV * const rstr = ((SVOP*)repl)->op_sv;
+ SV * const rstr =
+#ifdef PERL_MAD
+ (repl->op_type == OP_NULL)
+ ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
+#endif
+ ((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
const I32 squash = o->op_private & OPpTRANS_SQUASH;
I32 del = o->op_private & OPpTRANS_DELETE;
+ SV* swash;
PL_hints |= HINT_BLOCK_SCOPE;
if (SvUTF8(tstr))
else
bits = 8;
- Safefree(cPVOPo->op_pv);
- cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
+ PerlMemShared_free(cPVOPo->op_pv);
+ cPVOPo->op_pv = NULL;
+
+ swash = (SV*)swash_init("utf8", "", listsv, bits, none);
+#ifdef USE_ITHREADS
+ cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
+ SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
+ PAD_SETSV(cPADOPo->op_padix, swash);
+ SvPADTMP_on(swash);
+#else
+ cSVOPo->op_sv = swash;
+#endif
SvREFCNT_dec(listsv);
SvREFCNT_dec(transv);
if (!del && havefinal && rlen)
- (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
+ (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
newSVuv((UV)final), 0);
if (grows)
}
else if (j >= (I32)rlen)
j = rlen - 1;
- else
- cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
+ else {
+ tbl =
+ (short *)
+ PerlMemShared_realloc(tbl,
+ (0x101+rlen-j) * sizeof(short));
+ cPVOPo->op_pv = (char*)tbl;
+ }
tbl[0x100] = (short)(rlen - j);
for (i=0; i < (I32)rlen - j; i++)
tbl[0x101+i] = r[j+i];
pm->op_pmdynflags |= PMdf_UTF8;
/* FIXME - can we make this function take const char * args? */
PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
- if (strEQ("\\s+", PM_GETRE(pm)->precomp))
+ if (PM_GETRE(pm)->extflags & RXf_WHITE)
pm->op_pmflags |= PMf_WHITE;
+ else
+ pm->op_pmflags &= ~PMf_WHITE;
#ifdef PERL_MAD
op_getmad(expr,(OP*)pm,'e');
#else
else {
OP *lastop = NULL;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
- if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
+ if (curop->op_type == OP_SCOPE
+ || curop->op_type == OP_LEAVE
+ || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
if (curop->op_type == OP_GV) {
GV * const gv = cGVOPx_gv(curop);
repl_has_vars = 1;
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY) {
+ curop->op_type == OP_PADANY)
+ {
repl_has_vars = 1;
}
else if (curop->op_type == OP_PUSHRE)
if (curop == repl
&& !(repl_has_vars
&& (!PM_GETRE(pm)
- || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
+ || PM_GETRE(pm)->extflags & RXf_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);
* that value, we know we've got commonality. We could use a
* single bit marker, but then we'd have to make 2 passes, first
* to clear the flag, then to test and set it. To find somewhere
- * to store these values, evil chicanery is done with SvCUR().
+ * to store these values, evil chicanery is done with SvUVX().
*/
{
cop->op_next = (OP*)cop;
if (label) {
- cop->cop_label = label;
+ CopLABEL_set(cop, label);
PL_hints |= HINT_BLOCK_SCOPE;
}
cop->cop_seq = seq;
CopSTASH_set(cop, PL_curstash);
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef ) {
- (void)SvIOK_on(*svp);
- SvIV_set(*svp, PTR2IV(cop));
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
+ SvIV_set(*svp, PTR2IV(cop));
+ }
}
}
}
sv = NULL;
}
- else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
- padoff = sv->op_targ;
- if (PL_madskills)
- madsv = sv;
- else {
- sv->op_targ = 0;
- iterflags |= OPf_SPECIAL;
- op_free(sv);
- }
- sv = NULL;
- }
else
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
- if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
- iterpflags |= OPpITER_DEF;
+ if (padoff) {
+ SV *const namesv = PAD_COMPNAME_SV(padoff);
+ STRLEN len;
+ const char *const name = SvPV_const(namesv, len);
+
+ if (len == 2 && name[0] == '$' && name[1] == '_')
+ iterpflags |= OPpITER_DEF;
+ }
}
else {
const PADOFFSET offset = pad_findmy("$_");
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
- FreeOp(loop);
+ S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
#else
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
+ o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
? SvPVx_nolen_const(((SVOP*)label)->op_sv)
: ""));
}
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
Safefree(CvFILE(cv));
}
- CvFILE(cv) = 0;
+ CvFILE(cv) = NULL;
#endif
if (!CvISXSUB(cv) && CvROOT(cv)) {
gv_efullname3(name = sv_newmortal(), gv, NULL);
sv_setpv(msg, "Prototype mismatch:");
if (name)
- Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
+ Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
}
}
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
+ Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
}
}
}
if (CvLVALUE(cv)) {
CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
mod(scalarseq(block), OP_LEAVESUBLV));
+ block->op_attached = 1;
}
else {
/* This makes sub {}; work as expected. */
#endif
block = newblock;
}
+ else
+ block->op_attached = 1;
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
CvROOT(cv)->op_private |= OPpREFCOUNTED;
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
+ : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
o->op_ppaddr = PL_ppaddr[OP_PADSV];
return o;
}
- else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
- o->op_flags |= OPpDONE_SVREF;
- return o;
- }
return newUNOP(OP_RV2SV, 0, scalar(o));
}
if (badthing)
Perl_croak(aTHX_
"Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
- (void*)kidsv, badthing);
+ SVfARG(kidsv), badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
*/
priv = OPpDEREF;
if (kid->op_type == OP_PADSV) {
- name = PAD_COMPNAME_PV(kid->op_targ);
- /* SvCUR of a pad namesv can't be trusted
- * (see PL_generation), so calc its length
- * manually */
- if (name)
- len = strlen(name);
-
+ SV *const namesv
+ = PAD_COMPNAME_SV(kid->op_targ);
+ name = SvPV_const(namesv, len);
}
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
if (o3->op_type == OP_RV2SV ||
o3->op_type == OP_PADSV ||
o3->op_type == OP_HELEM ||
- o3->op_type == OP_AELEM ||
- o3->op_type == OP_THREADSV)
+ o3->op_type == OP_AELEM)
goto wrapref;
if (!contextclass)
bad_type(arg, "scalar", gv_ename(namegv), o3);
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), (void*)cv);
+ gv_ename(namegv), SVfARG(cv));
}
}
else
gv_efullname3(sv, gv, NULL);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%"SVf"() called too early to check prototype",
- (void*)sv);
+ SVfARG(sv));
}
}
else if (o->op_next->op_type == OP_READLINE
projects / p5sagit/p5-mst-13.2.git / blobdiff