PADOFFSET
Perl_pad_allocmy(pTHX_ char *name)
{
- dTHR;
PADOFFSET off;
SV *sv;
S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
I32 cx_ix, I32 saweval, U32 flags)
{
- dTHR;
CV *cv;
I32 off;
SV *sv;
PADOFFSET
Perl_pad_findmy(pTHX_ char *name)
{
- dTHR;
I32 off;
I32 pendoff = 0;
SV *sv;
void
Perl_pad_leavemy(pTHX_ I32 fill)
{
- dTHR;
I32 off;
SV **svp = AvARRAY(PL_comppad_name);
SV *sv;
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
- dTHR;
SV *sv;
I32 retval;
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
- dTHR;
#ifdef USE_THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
- dTHR;
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
void
Perl_pad_swipe(pTHX_ PADOFFSET po)
{
- dTHR;
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_swipe curpad");
if (!po)
Perl_pad_reset(pTHX)
{
#ifdef USE_BROKEN_PAD_RESET
- dTHR;
register I32 po;
if (AvARRAY(PL_comppad) != PL_curpad)
PADOFFSET
Perl_find_threadsv(pTHX_ const char *name)
{
- dTHR;
char *p;
PADOFFSET key;
SV **svp;
#endif
if (! specialWARN(cop->cop_warnings))
SvREFCNT_dec(cop->cop_warnings);
+ if (! specialCopIO(cop->cop_io))
+ SvREFCNT_dec(cop->cop_io);
}
STATIC void
S_scalarboolean(pTHX_ OP *o)
{
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
- dTHR;
if (ckWARN(WARN_SYNTAX)) {
line_t oldline = CopLINE(PL_curcop);
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
|| o->op_targ == OP_SETSTATE
|| o->op_targ == OP_DBSTATE)))
- {
- dTHR;
PL_curcop = (COP*)o; /* for warning below */
- }
/* assumes no premature commitment */
want = o->op_flags & OPf_WANT;
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
else {
- dTHR;
if (ckWARN(WARN_VOID)) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
}
break;
}
- if (useless) {
- dTHR;
- if (ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
- }
+ if (useless && ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
return o;
}
o->op_type == OP_LEAVE ||
o->op_type == OP_LEAVETRY)
{
- dTHR;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling) {
scalarvoid(kid);
OP *
Perl_mod(pTHX_ OP *o, I32 type)
{
- dTHR;
OP *kid;
STRLEN n_a;
OP *
Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
{
- dTHR;
OP *o;
if (ckWARN(WARN_MISC) &&
int
Perl_block_start(pTHX_ int full)
{
- dTHR;
int retval = PL_savestack_ix;
SAVEI32(PL_comppad_name_floor);
PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
SAVEFREESV(PL_compiling.cop_warnings) ;
}
+ SAVESPTR(PL_compiling.cop_io);
+ if (! specialCopIO(PL_compiling.cop_io)) {
+ PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
+ SAVEFREESV(PL_compiling.cop_io) ;
+ }
return retval;
}
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
- dTHR;
int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
LEAVE_SCOPE(floor);
void
Perl_newPROG(pTHX_ OP *o)
{
- dTHR;
if (PL_in_eval) {
if (PL_eval_root)
return;
if (o->op_flags & OPf_PARENS)
list(o);
else {
- dTHR;
if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
char *s;
for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
OP *
Perl_fold_constants(pTHX_ register OP *o)
{
- dTHR;
register OP *curop;
I32 type = o->op_type;
SV *sv;
OP *
Perl_gen_constant_list(pTHX_ register OP *o)
{
- dTHR;
register OP *curop;
I32 oldtmps_floor = PL_tmps_floor;
SV* transv = 0;
U8* tend = t + tlen;
U8* rend = r + rlen;
- I32 ulen;
+ STRLEN ulen;
U32 tfirst = 1;
U32 tlast = 0;
I32 tdiff;
I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
if (complement) {
- U8 tmpbuf[UTF8_MAXLEN];
+ U8 tmpbuf[UTF8_MAXLEN+1];
U8** cp;
+ I32* cl;
UV nextmin = 0;
New(1109, cp, tlen, U8*);
i = 0;
qsort(cp, i, sizeof(U8*), utf8compare);
for (j = 0; j < i; j++) {
U8 *s = cp[j];
- UV val = utf8_to_uv_chk(s, &ulen, 0);
+ I32 cur = j < i ? cp[j+1] - s : tend - s;
+ UV val = utf8_to_uv(s, cur, &ulen, 0);
s += ulen;
diff = val - nextmin;
if (diff > 0) {
}
}
if (*s == 0xff)
- val = utf8_to_uv_chk(s+1, &ulen, 0);
+ val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
if (val >= nextmin)
nextmin = val + 1;
}
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8_to_uv_chk(t, &ulen, 0);
+ tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
t += ulen;
if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
- tlast = (I32)utf8_to_uv_chk(++t, &ulen, 0);
+ t++;
+ tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8_to_uv_chk(r, &ulen, 0);
+ rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
r += ulen;
if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
- rlast = (I32)utf8_to_uv_chk(++r, &ulen, 0);
+ r++;
+ rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
r += ulen;
}
else
OP *
Perl_newPMOP(pTHX_ I32 type, I32 flags)
{
- dTHR;
PMOP *pmop;
NewOp(1101, pmop, 1, PMOP);
OP *
Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
{
- dTHR;
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
- if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE)))
+ if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
if (strEQ("\\s+", pm->op_pmregexp->precomp))
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
- dTHR;
#ifdef USE_ITHREADS
GvIN_PAD_on(gv);
return newPADOP(type, flags, SvREFCNT_inc(gv));
void
Perl_package(pTHX_ OP *o)
{
- dTHR;
SV *sv;
save_hptr(&PL_curstash);
}
if (list_assignment(left)) {
- dTHR;
OP *curop;
PL_modcount = 0;
OP *
Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
{
- dTHR;
U32 seq = intro_my();
register COP *cop;
cop->cop_warnings = PL_curcop->cop_warnings ;
else
cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+ if (specialCopIO(PL_curcop->cop_io))
+ cop->cop_io = PL_curcop->cop_io;
+ else
+ cop->cop_io = newSVsv(PL_curcop->cop_io) ;
if (PL_copline == NOLINE)
STATIC OP *
S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
{
- dTHR;
LOGOP *logop;
OP *o;
OP *first = *firstp;
OP *
Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
{
- dTHR;
LOGOP *logop;
OP *start;
OP *o;
OP *
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
- dTHR;
LOGOP *range;
OP *flip;
OP *flop;
OP *
Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
{
- dTHR;
OP* listop;
OP* o;
int once = block && block->op_flags & OPf_SPECIAL &&
OP *
Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
{
- dTHR;
OP *redo;
OP *next = 0;
OP *listop;
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
- dTHR;
OP *o;
STRLEN n_a;
void
Perl_cv_undef(pTHX_ CV *cv)
{
- dTHR;
#ifdef USE_THREADS
if (CvMUTEXP(cv)) {
MUTEX_DESTROY(CvMUTEXP(cv));
CvGV(cv) = Nullgv;
SvREFCNT_dec(CvOUTSIDE(cv));
CvOUTSIDE(cv) = Nullcv;
+ if (CvCONST(cv)) {
+ SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
+ CvCONST_off(cv);
+ }
if (CvPADLIST(cv)) {
/* may be during global destruction */
if (SvREFCNT(CvPADLIST(cv))) {
STATIC CV *
S_cv_clone2(pTHX_ CV *proto, CV *outside)
{
- dTHR;
AV* av;
I32 ix;
AV* protopadlist = CvPADLIST(proto);
#endif
LEAVE;
+
+ if (CvCONST(cv)) {
+ SV* const_sv = op_const_sv(CvSTART(cv), cv);
+ assert(const_sv);
+ /* constant sub () { $x } closing over $x - see lib/constant.pm */
+ SvREFCNT_dec(cv);
+ cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
+ }
+
return cv;
}
void
Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
{
- dTHR;
-
if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
SV* msg = sv_newmortal();
SV* name = Nullsv;
}
}
+static void const_sv_xsub(pTHXo_ CV* cv);
+
+/*
+=for apidoc cv_const_sv
+
+If C<cv> is a constant sub eligible for inlining. returns the constant
+value returned by the sub. Otherwise, returns NULL.
+
+Constant subs can be created with C<newCONSTSUB> or as described in
+L<perlsub/"Constant Functions">.
+
+=cut
+*/
SV *
Perl_cv_const_sv(pTHX_ CV *cv)
{
- if (!cv || !SvPOK(cv) || SvCUR(cv))
+ if (!cv || !CvCONST(cv))
return Nullsv;
- return op_const_sv(CvSTART(cv), cv);
+ return (SV*)CvXSUBANY(cv).any_ptr;
}
SV *
if (sv && o->op_next == o)
return sv;
- if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
- continue;
+ if (o->op_next != o) {
+ if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
+ continue;
+ if (type == OP_DBSTATE)
+ continue;
+ }
if (type == OP_LEAVESUB || type == OP_RETURN)
break;
if (sv)
else if ((type == OP_PADSV || type == OP_CONST) && cv) {
AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
- if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
+ if (!sv)
+ return Nullsv;
+ if (CvCONST(cv)) {
+ /* We get here only from cv_clone2() while creating a closure.
+ Copy the const value here instead of in cv_clone2 so that
+ SvREADONLY_on doesn't lead to problems when leaving
+ scope.
+ */
+ sv = newSVsv(sv);
+ }
+ if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
return Nullsv;
}
else
CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- dTHR;
STRLEN n_a;
char *name;
char *aname;
char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
register CV *cv=0;
I32 ix;
+ SV *const_sv;
name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
PL_sub_generation++;
- goto noblock;
+ goto done;
}
- if (!name || GvCVGEN(gv))
- cv = Nullcv;
- else if ((cv = GvCV(gv))) {
+ cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
+
+ if (!block || !ps || *ps || attrs)
+ const_sv = Nullsv;
+ else
+ const_sv = op_const_sv(block, Nullcv);
+
+ if (cv) {
bool exists = CvROOT(cv) || CvXSUB(cv);
/* if the subroutine doesn't exist and wasn't pre-declared
* with a prototype, assume it will be AUTOLOADed,
cv_ckproto(cv, gv, ps);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
- SV* const_sv;
- bool const_changed = TRUE;
if (!block && !attrs) {
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
/* ahem, death to those who redefine active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
- if (!block)
- goto withattrs;
- 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))
- {
- line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE,
- const_sv ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined", name);
- CopLINE_set(PL_curcop, oldline);
+ if (block) {
+ if (ckWARN(WARN_REDEFINE)
+ || (CvCONST(cv)
+ && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
+ {
+ line_t oldline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, PL_copline);
+ Perl_warner(aTHX_ WARN_REDEFINE,
+ CvCONST(cv) ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined", name);
+ CopLINE_set(PL_curcop, oldline);
+ }
+ SvREFCNT_dec(cv);
+ cv = Nullcv;
}
- SvREFCNT_dec(cv);
- cv = Nullcv;
}
}
- withattrs:
+ if (const_sv) {
+ SvREFCNT_inc(const_sv);
+ if (cv) {
+ assert(!CvROOT(cv) && !CvCONST(cv));
+ sv_setpv((SV*)cv, ""); /* prototype is "" */
+ CvXSUBANY(cv).any_ptr = const_sv;
+ CvXSUB(cv) = const_sv_xsub;
+ CvCONST_on(cv);
+ }
+ else {
+ GvCV(gv) = Nullcv;
+ cv = newCONSTSUB(NULL, name, const_sv);
+ }
+ op_free(block);
+ SvREFCNT_dec(PL_compcv);
+ PL_compcv = NULL;
+ PL_sub_generation++;
+ goto done;
+ }
if (attrs) {
HV *stash;
SV *rcv;
}
}
}
- if (!block) {
- noblock:
- PL_copline = NOLINE;
- LEAVE_SCOPE(floor);
- return cv;
- }
+ if (!block)
+ goto done;
if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
PL_curpad[ix] = Nullsv;
}
}
+ assert(!CvCONST(cv));
+ if (ps && !*ps && op_const_sv(block, cv))
+ CvCONST_on(cv);
}
else {
AV *av = newAV(); /* Will be @_ */
=cut
*/
-void
+CV *
Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
{
- dTHR;
+ CV* cv;
ENTER;
#endif
}
- newATTRSUB(
- start_subparse(FALSE, 0),
- newSVOP(OP_CONST, 0, newSVpv(name,0)),
- newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
- Nullop,
- newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
- );
+ cv = newXS(name, const_sv_xsub, __FILE__);
+ CvXSUBANY(cv).any_ptr = sv;
+ CvCONST_on(cv);
+ sv_setpv((SV*)cv, ""); /* prototype is "" */
LEAVE;
+
+ return cv;
}
/*
CV *
Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
{
- dTHR;
GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
register CV *cv;
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name);
+ Perl_warner(aTHX_ WARN_REDEFINE,
+ CvCONST(cv) ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined"
+ ,name);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
- dTHR;
register CV *cv;
char *name;
GV *gv;
OP *
Perl_oopsHV(pTHX_ OP *o)
{
- dTHR;
-
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
OP *
Perl_ck_rvconst(pTHX_ register OP *o)
{
- dTHR;
SVOP *kid = (SVOP*)cUNOPo->op_first;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
OP *
Perl_ck_ftst(pTHX_ OP *o)
{
- dTHR;
I32 type = o->op_type;
if (o->op_flags & OPf_REF) {
OP *
Perl_ck_fun(pTHX_ OP *o)
{
- dTHR;
register OP *kid;
OP **tokid;
OP *sibl;
OP *
Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
{
- dTHR;
if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
- dTHR;
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int reversed;
OP *
Perl_ck_subr(pTHX_ OP *o)
{
- dTHR;
OP *prev = ((cUNOPo->op_first->op_sibling)
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
return ck_fun(o);
}
+OP *
+Perl_ck_substr(pTHX_ OP *o)
+{
+ o = ck_fun(o);
+ if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
+ OP *kid = cLISTOPo->op_first;
+
+ if (kid->op_type == OP_NULL)
+ kid = kid->op_sibling;
+ if (kid)
+ kid->op_flags |= OPf_MOD;
+
+ }
+ return o;
+}
+
/* A peephole optimizer. We visit the ops in the order they're to execute. */
void
Perl_peep(pTHX_ register OP *o)
{
- dTHR;
register OP* oldop = 0;
STRLEN n_a;
OP *last_composite = Nullop;
PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
if (SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
- * another pad, so make a copy. */
+ * some pad, so make a copy. */
sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
SvREADONLY_on(PL_curpad[ix]);
SvREFCNT_dec(cSVOPo->op_sv);
SvREFCNT_dec(PL_curpad[ix]);
SvPADTMP_on(cSVOPo->op_sv);
PL_curpad[ix] = cSVOPo->op_sv;
+ /* XXX I don't know how this isn't readonly already. */
+ SvREADONLY_on(PL_curpad[ix]);
}
cSVOPo->op_sv = Nullsv;
o->op_targ = ix;
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
key = SvPV(sv, keylen);
lexname = newSVpvn_share(key, keylen, 0);
+ if (SvUTF8(sv))
+ SvUTF8_on(lexname);
SvREFCNT_dec(sv);
*svp = lexname;
}
}
LEAVE;
}
+
+#include "XSUB.h"
+
+/* Efficient sub that returns a constant scalar value. */
+static void
+const_sv_xsub(pTHXo_ CV* cv)
+{
+ dXSARGS;
+ EXTEND(sp, 1);
+ ST(0) = (SV*)XSANY.any_ptr;
+ XSRETURN(1);
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff