SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
- sv->sv_debug_line = (U16) ((PL_parser && PL_parser->copline == NOLINE) ?
- (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_parser->copline);
+ sv->sv_debug_line = (U16) (PL_parser
+ ? PL_parser->copline == NOLINE
+ ? PL_curcop
+ ? CopLINE(PL_curcop)
+ : 0
+ : PL_parser->copline
+ : 0);
sv->sv_debug_inpad = 0;
sv->sv_debug_cloned = 0;
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
#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++;
SvOBJECT(GvSV(sv))) ||
(GvAV(sv) && SvOBJECT(GvAV(sv))) ||
(GvHV(sv) && SvOBJECT(GvHV(sv))) ||
- (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
+ /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
+ (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
(GvCV(sv) && SvOBJECT(GvCV(sv))) )
{
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(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;
}
/* and won't be needed again, potentially */
!(PL_op && PL_op->op_type == OP_AASSIGN))
#ifdef PERL_OLD_COPY_ON_WRITE
- && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
- && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV)
+ && ((flags & SV_COW_SHARED_HASH_KEYS)
+ ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+ && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
+ && SvTYPE(sstr) >= SVt_PVIV))
+ : 1)
#endif
) {
/* Failed the swipe test, and it's not a shared hash key either.
}
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 {
if (PL_utf8cache) {
STRLEN ulen;
- MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
+ MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
if (mg && mg->mg_len != -1) {
ulen = mg->mg_len;
Creates a new SV with its SvPVX_const pointing to a shared string in the string
table. If the string does not already exist in the table, it is created
-first. Turns on READONLY and FAKE. The string's hash is stored in the UV
-slot of the SV; if the C<hash> parameter is non-zero, that value is used;
-otherwise the hash is computed. The idea here is that as the string table
-is used for shared hash keys these strings will have SvPVX_const == HeKEY and
-hash lookup will avoid string compare.
+first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
+value is used; otherwise the hash is computed. The string's hash can be later
+be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
+that as the string table is used for shared hash keys these strings will have
+SvPVX_const == HeKEY and hash lookup will avoid string compare.
=cut
*/
/*
=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 (c != 'e' && c != 'E') {
+ /* 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_savestack_ix = 0;
PL_savestack_max = -1;
PL_sig_pending = 0;
+ PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
PL_savestack_ix = 0;
PL_savestack_max = -1;
PL_sig_pending = 0;
+ PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
PL_sub_generation = proto_perl->Isub_generation;
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
- PL_delayedisa = hv_dup_inc(proto_perl->Idelayedisa, param);
/* funky return mechanisms */
PL_forkprocess = proto_perl->Iforkprocess;
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;
PL_Sv = NULL;
PL_Xpv = (XPV*)NULL;
- PL_na = proto_perl->Ina;
+ my_perl->Ina = proto_perl->Ina;
PL_statbuf = proto_perl->Istatbuf;
PL_statcache = proto_perl->Istatcache;
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))
+ break;
+
case OP_SCHOMP:
case OP_CHOMP:
if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))