}
}
if (!ok) {
- if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free non-arena SV: 0x%"UVxf
- pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free non-arena SV: 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
return;
}
}
SvNV_set(sv, 0);
#endif
- if (new_type == SVt_PVIO)
+ if (new_type == SVt_PVIO) {
+ IO * const io = MUTABLE_IO(sv);
+ GV *iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
+
+ SvOBJECT_on(io);
+ /* Clear the stashcache because a new IO could overrule a package
+ name */
+ hv_clear(PL_stashcache);
+
+ /* unless exists($main::{FileHandle}) and
+ defined(%main::FileHandle::) */
+ if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
+ iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
+ SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
+ }
if (old_type < SVt_PV) {
/* referant will be NULL unless the old type was SVt_IV emulating
SVt_RV */
}
else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
if (!(sflags & SVf_OK)) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Undefined value assigned to typeglob");
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Undefined value assigned to typeglob");
}
else {
GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
case PERL_MAGIC_qr:
vtable = &PL_vtbl_regexp;
break;
- case PERL_MAGIC_hints:
- /* As this vtable is all NULL, we can reuse it. */
case PERL_MAGIC_sig:
vtable = &PL_vtbl_sig;
break;
case PERL_MAGIC_hintselem:
vtable = &PL_vtbl_hintselem;
break;
+ case PERL_MAGIC_hints:
+ vtable = &PL_vtbl_hints;
+ break;
case PERL_MAGIC_ext:
/* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
return sv;
}
tsv = SvRV(sv);
#ifdef DEBUGGING
if (SvTEMP(sv)) {
- if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "Attempt to free temp prematurely: SV 0x%"UVxf
- pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+ "Attempt to free temp prematurely: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
return;
}
#endif
}
assert(cache);
- if (PL_utf8cache < 0) {
+ if (PL_utf8cache < 0 && SvPOKp(sv)) {
+ /* SvPOKp() because it's possible that sv has string overloading, and
+ therefore is a reference, hence SvPVX() is actually a pointer.
+ This cures the (very real) symptoms of RT 69422, but I'm not actually
+ sure whether we should even be caching the results of UTF-8
+ operations on overloading, given that nothing stops overloading
+ returning a different value every time it's called. */
const U8 *start = (const U8 *) SvPVX_const(sv);
const STRLEN realutf8 = utf8_length(start, start + byte);
if (flags & SVp_NOK) {
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
- was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
- Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
- "Lost precision when incrementing %" NVff " by 1",
- was);
+ was >= NV_OVERFLOWS_INTEGERS_AT) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
+ "Lost precision when incrementing %" NVff " by 1",
+ was);
}
(void)SvNOK_only(sv);
SvNV_set(sv, was + 1.0);
d = SvPVX(sv);
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
- if (*d) {
+ if (d < SvEND(sv)) {
#ifdef PERL_PRESERVE_IVUV
/* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
{
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
- was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
- Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
- "Lost precision when decrementing %" NVff " by 1",
- was);
+ was <= -NV_OVERFLOWS_INTEGERS_AT) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
+ "Lost precision when decrementing %" NVff " by 1",
+ was);
}
(void)SvNOK_only(sv);
SvNV_set(sv, was - 1.0);
sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
}
+/* this define is used to eliminate a chunk of duplicated but shared logic
+ * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
+ * used anywhere but here - yves
+ */
+#define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
+ STMT_START { \
+ EXTEND_MORTAL(1); \
+ PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
+ } STMT_END
+
/*
=for apidoc sv_mortalcopy
new_SV(sv);
sv_setsv(sv,oldstr);
- EXTEND_MORTAL(1);
- PL_tmps_stack[++PL_tmps_ix] = sv;
+ PUSH_EXTEND_MORTAL__SV_C(sv);
SvTEMP_on(sv);
return sv;
}
new_SV(sv);
SvFLAGS(sv) = SVs_TEMP;
- EXTEND_MORTAL(1);
- PL_tmps_stack[++PL_tmps_ix] = sv;
+ PUSH_EXTEND_MORTAL__SV_C(sv);
return sv;
}
assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
new_SV(sv);
sv_setpvn(sv,s,len);
- SvFLAGS(sv) |= (flags & SVf_UTF8);
- return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
+
+ /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
+ * and do what it does outselves here.
+ * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
+ * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
+ * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
+ * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
+ */
+
+ SvFLAGS(sv) |= flags;
+
+ if(flags & SVs_TEMP){
+ PUSH_EXTEND_MORTAL__SV_C(sv);
+ }
+
+ return sv;
}
/*
return NULL;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
return sv;
- EXTEND_MORTAL(1);
- PL_tmps_stack[++PL_tmps_ix] = sv;
+ PUSH_EXTEND_MORTAL__SV_C(sv);
SvTEMP_on(sv);
return sv;
}
if (!old)
return NULL;
if (SvTYPE(old) == SVTYPEMASK) {
- if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return NULL;
}
new_SV(sv);
Using various gambits, try to get a CV from an SV; in addition, try if
possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
-The flags in C<lref> are passed to sv_fetchsv.
+The flags in C<lref> are passed to gv_fetchsv.
=cut
*/
goto string;
}
else if (n) {
- if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "internal %%<num>p might conflict with future printf extensions");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "internal %%<num>p might conflict with future printf extensions");
}
}
q = r;
/* utf8 character classes */
PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
- PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
proto_perl->Itmps_stack[i]));
if (nsv && !SvREFCNT(nsv)) {
- EXTEND_MORTAL(1);
- PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
+ PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
}
}
}
projects / p5sagit/p5-mst-13.2.git / blobdiff