#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
- /* Must always set typemask because it's awlays checked in on cleanup
+ /* Must always set typemask because it's always checked in on cleanup
when the arenas are walked looking for objects. */
SvFLAGS(sv) = SVTYPEMASK;
sv++;
memory in the last arena-set (1/2 on average). In trade, we get
back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
smaller types). The recovery of the wasted space allows use of
- small arenas for large, rare body types,
+ small arenas for large, rare body types, by changing array* fields
+ in body_details_by_type[] below.
*/
struct arena_desc {
char *arena; /* the raw storage, allocated aligned */
struct arena_set;
/* Get the maximum number of elements in set[] such that struct arena_set
- will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and
+ will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
therefore likely to be 1 aligned memory page. */
#define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
if (old_type == new_type)
return;
- if (old_type > new_type)
- Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
- (int)old_type, (int)new_type);
-
-
old_body = SvANY(sv);
/* Copying structures onto other structures that have been neatly zeroed
Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
}
+
+ if (old_type > new_type)
+ Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
+ (int)old_type, (int)new_type);
+
new_type_details = bodies_by_type + new_type;
SvFLAGS(sv) &= ~SVTYPEMASK;
AvMAX(sv) = -1;
AvFILLp(sv) = -1;
AvREAL_only(sv);
+ if (old_type_details->body_size) {
+ AvALLOC(sv) = 0;
+ } else {
+ /* It will have been zeroed when the new body was allocated.
+ Lets not write to it, in case it confuses a write-back
+ cache. */
+ }
+ } else {
+ assert(!SvOK(sv));
+ SvOK_off(sv);
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(sv); /* key-sharing on by default */
+#endif
+ HvMAX(sv) = 7; /* (start with 8 buckets) */
+ if (old_type_details->body_size) {
+ HvFILL(sv) = 0;
+ } else {
+ /* It will have been zeroed when the new body was allocated.
+ Lets not write to it, in case it confuses a write-back
+ cache. */
+ }
}
/* SVt_NULL isn't the only thing upgraded to AV or HV.
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
- sv_upgrade(sv, SVt_IV);
- break;
case SVt_NV:
- sv_upgrade(sv, SVt_PVNV);
+ sv_upgrade(sv, SVt_IV);
break;
case SVt_RV:
case SVt_PV:
return SvNVX(sv);
}
+/*
+=for apidoc sv_2num
+
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion. You must use the C<SvNUM(sv)> macro to
+access this function.
+
+=cut
+*/
+
+SV *
+Perl_sv_2num(pTHX_ register SV *sv)
+{
+ if (!SvROK(sv))
+ return sv;
+ if (SvAMAGIC(sv)) {
+ SV * const tmpsv = AMG_CALLun(sv,numer);
+ if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+ return sv_2num(tmpsv);
+ }
+ return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
+}
+
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
* UV as a string towards the end of buf, and return pointers to start and
* end of it.
}
errno = olderrno;
#ifdef FIXNEGATIVEZERO
- if (*s == '-' && s[1] == '0' && !s[2])
- my_strlcpy(s, "0", SvLEN(s));
+ if (*s == '-' && s[1] == '0' && !s[2]) {
+ s[0] = '0';
+ s[1] = 0;
+ }
#endif
while (*s) s++;
#ifdef hcx
}
if (dtype >= SVt_PV) {
- if (dtype == SVt_PVGV) {
+ if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
glob_assign_ref(dstr, sstr);
return;
}
}
if (SvOBJECT(sv)) {
- if (PL_defstash) { /* Still have a symbol table? */
+ if (PL_defstash && /* Still have a symbol table? */
+ SvDESTROYABLE(sv))
+ {
dSP;
HV* stash;
do {
/*
=for apidoc newSV_type
-Creates a new SV, of the type specificied. The reference count for the new SV
+Creates a new SV, of the type specified. The reference count for the new SV
is set to 1.
=cut
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
+ if (SvIsCOW(tmpRef))
+ sv_force_normal_flags(tmpRef, 0);
if (SvREADONLY(tmpRef))
Perl_croak(aTHX_ PL_no_modify);
if (SvOBJECT(tmpRef)) {
%p include pointer address (standard)
%-p (SVf) include an SV (previously %_)
%-<num>p include an SV with precision <num>
- %1p (VDf) include a v-string (as %vd)
%<num>p reserved for future extensions
Robin Barker 2005-07-14
+
+ %1p (VDf) removed. RMB 2007-10-19
*/
char* r = q;
bool sv = FALSE;
is_utf8 = TRUE;
goto string;
}
-#if vdNUMBER
- else if (n == vdNUMBER) { /* VDf */
- vectorize = TRUE;
- VECTORIZE_ARGS
- goto format_vd;
- }
-#endif
else if (n) {
if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
: SvNV(argsv);
need = 0;
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- if (c != 'e' && c != 'E' && !Perl_isnan(nv))
-#else
- if (c != 'e' && c != 'E' && nv == nv)
-#endif
- {
+ /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
+ else. frexp() has some unspecified behaviour for those three */
+ if (c != 'e' && c != 'E' && (nv * 0) == 0) {
i = PERL_INT_MIN;
/* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
will cast our (long double) to (double) */
All the macros and functions in this section are for the private use of
the main function, perl_clone().
-The foo_dup() functions make an exact copy of an existing foo thinngy.
+The foo_dup() functions make an exact copy of an existing foo thingy.
During the course of a cloning, a hash table is used to map old addresses
to new addresses. The table is created and manipulated with the
ptr_table_* functions.
/** We are joining here so we don't want do clone
something that is bad **/
if (SvTYPE(sstr) == SVt_PVHV) {
- const char * const hvname = HvNAME_get(sstr);
+ const HEK * const hvname = HvNAME_HEK(sstr);
if (hvname)
/** don't clone stashes if they already exist **/
- return (SV*)gv_stashpv(hvname,0);
+ return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
}
}
/* don't clone objects whose class has asked us not to */
if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
- SvFLAGS(dstr) &= ~SVTYPEMASK;
- SvOBJECT_off(dstr);
+ SvFLAGS(dstr) = 0;
return dstr;
}
PL_runops = proto_perl->Irunops;
-#ifdef CSH
- PL_cshlen = proto_perl->Icshlen;
- PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
-#endif
-
PL_parser = parser_dup(proto_perl->Iparser, param);
PL_subline = proto_perl->Isubline;
PL_lockhook = proto_perl->Ilockhook;
PL_unlockhook = proto_perl->Iunlockhook;
PL_threadhook = proto_perl->Ithreadhook;
+ PL_destroyhook = proto_perl->Idestroyhook;
#ifdef THREADS_HAVE_PIDS
PL_ppid = proto_perl->Ippid;
case OP_RV2SV:
case OP_CUSTOM:
- case OP_ENTERSUB:
match = 1; /* XS or custom code could trigger random warnings */
goto do_op;
+ case OP_ENTERSUB:
+ case OP_GOTO:
+ /* XXX tmp hack: these two may call an XS sub, and currently
+ XS subs don't have a SUB entry on the context stack, so CV and
+ pad determination goes wrong, and BAD things happen. So, just
+ don't try to determine the value under those circumstances.
+ Need a better fix at dome point. DAPM 11/2007 */
+ break;
+
case OP_POS:
/* def-ness of rval pos() is independent of the def-ness of its arg */
if ( !(obase->op_flags & OPf_MOD))
projects / p5sagit/p5-mst-13.2.git / blobdiff