/* HEs use this offset for their arena. */
{ 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
- /* The bind placeholder pretends to be an RV for now.
- Also it's marked as "can't upgrade" to stop anyone using it before it's
- implemented. */
- { 0, 0, 0, SVt_DUMMY, TRUE, NONV, NOARENA, 0 },
-
/* IVs are in the head, so the allocation size is 0. */
{ 0,
sizeof(IV), /* This is used to copy out the IV body. */
SVt_PV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+ /* The invlist placeholder pretends to be an RV for now.
+ Also it's marked as "can't upgrade" to stop anyone using it before it's
+ implemented. */
+ { 0, 0, 0, SVt_INVLIST, TRUE, NONV, NOARENA, 0 },
+
{ sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
{ sizeof(regexp),
sizeof(regexp),
0,
- SVt_REGEXP, FALSE, NONV, HASARENA,
+ SVt_REGEXP, TRUE, NONV, HASARENA,
FIT_ARENA(0, sizeof(regexp))
},
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(sv); /* key-sharing on by default */
#endif
- HvMAX(sv) = 7; /* (start with 8 buckets) */
+ /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
+ HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
}
/* SVt_NULL isn't the only thing upgraded to AV or HV.
PERL_ARGS_ASSERT_SV_GROW;
- if (PL_madskills && newlen >= 0x100000) {
- PerlIO_printf(Perl_debug_log,
- "Allocation too large: %"UVxf"\n", (UV)newlen);
- }
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
s = SvPVX_mutable(sv);
}
+#ifdef PERL_NEW_COPY_ON_WRITE
+ /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
+ * to store the COW count. So in general, allocate one more byte than
+ * asked for, to make it likely this byte is always spare: and thus
+ * make more strings COW-able.
+ * If the new size is a big power of two, don't bother: we assume the
+ * caller wanted a nice 2^N sized block and will be annoyed at getting
+ * 2^N+1 */
+ if (newlen & 0xff)
+ newlen++;
+#endif
+
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
Move(ptr, s, len, char);
s += len;
*s = '\0';
+ SvPOK_on(sv);
}
else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
/* The +20 is pure guesswork. Configure test needed. --jhi */
s = SvGROW_mutable(sv, NV_DIG + 20);
/* some Xenix systems wipe out errno here */
- Gconvert(SvNVX(sv), NV_DIG, 0, s);
+
+#ifndef USE_LOCALE_NUMERIC
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ SvPOK_on(sv);
+#else
+ /* Gconvert always uses the current locale. That's the right thing
+ * to do if we're supposed to be using locales. But otherwise, we
+ * want the result to be based on the C locale, so we need to
+ * change to the C locale during the Gconvert and then change back.
+ * But if we're already in the C locale (PL_numeric_standard is
+ * TRUE in that case), no need to do any changing */
+ if (PL_numeric_standard || IN_LOCALE_RUNTIME) {
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ }
+ else {
+ char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
+ }
+
+ /* We don't call SvPOK_on(), because it may come to pass that the
+ * locale changes so that the stringification we just did is no
+ * longer correct. We will have to re-stringify every time it is
+ * needed */
+#endif
RESTORE_ERRNO;
while (*s) s++;
}
*lp = len;
SvCUR_set(sv, len);
}
- SvPOK_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
PTR2UV(sv),SvPVX_const(sv)));
if (flags & SV_CONST_RETURN)
);
}
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
+ if (GvIO(dstr) && dtype == SVt_PVGV) {
+ DEBUG_o(Perl_deb(aTHX_
+ "glob_assign_glob clearing PL_stashcache\n"));
+ /* It's a cache. It will rebuild itself quite happily.
+ It's a lot of effort to work out exactly which key (or keys)
+ might be invalidated by the creation of the this file handle.
+ */
+ hv_clear(PL_stashcache);
+ }
return;
}
}
break;
- /* case SVt_DUMMY: */
+ /* case SVt_INVLIST: */
case SVt_PVLV:
case SVt_PVGV:
case SVt_PVMG:
#ifdef PERL_ANY_COW
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
Perl_croak_no_modify();
}
else if (SvIsCOW(sv)) {
}
#else
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
Perl_croak_no_modify();
}
else
evacp = p - evacn;
#endif
+ /* This sets 'delta' to the accumulated value of all deltas so far */
delta += old_delta;
assert(delta);
+
+ /* If 'delta' fits in a byte, store it just prior to the new beginning of
+ * the string; otherwise store a 0 byte there and store 'delta' just prior
+ * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
+ * portion of the chopped part of the string */
if (delta < 0x100) {
*--p = (U8) delta;
} else {
vtable = (vtable_index == magic_vtable_max)
? NULL : PL_magic_vtables + vtable_index;
-#ifdef PERL_ANY_COW
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
- /* case SVt_DUMMY: */
+ /* case SVt_INVLIST: */
case SVt_PVIO:
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
PERL_ARGS_ASSERT_SV_FREE2;
- if (rc == 1) {
+ if (LIKELY( rc == 1 )) {
/* normal case */
SvREFCNT(sv) = 0;
char todo[PERL_UCHAR_MAX+1];
const char *send;
- if (!stash)
+ if (!stash || SvTYPE(stash) != SVt_PVHV)
return;
if (!s) { /* reset ?? searches */
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
if (flags & SV_GMAGIC) SvGETMAGIC(sv);
- if (SvTHINKFIRST(sv) && !SvROK(sv))
+ if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
char *s;
STRLEN len;
- if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
- const char * const ref = sv_reftype(sv,0);
- if (PL_op)
- Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
- ref, OP_DESC(PL_op));
- else
- Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
- }
if (SvTYPE(sv) > SVt_PVLV
|| isGV_with_GP(sv))
/* diag_listed_as: Can't coerce %s to %s in %s */
? "GLOB" : "SCALAR");
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
- case SVt_DUMMY: return "DUMMY";
+ case SVt_INVLIST: return "INVLIST";
case SVt_REGEXP: return "REGEXP";
default: return "UNKNOWN";
}
%-<num>p include an SV with precision <num>
%2p include a HEK
%3p include a HEK with precision of 256
- %<num>p (where num != 2 or 3) reserved for future
+ %4p char* preceded by utf8 flag and length
+ %<num>p (where num is 1 or > 4) reserved for future
extensions
Robin Barker 2005-07-14 (but modified since)
STRLEN n = 0;
if (*q == '-')
sv = *q++;
+ else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
+ /* The argument has already gone through cBOOL, so the cast
+ is safe. */
+ is_utf8 = (bool)va_arg(*args, int);
+ elen = va_arg(*args, UV);
+ eptr = va_arg(*args, char *);
+ q += sizeof(UTF8f)-1;
+ goto string;
+ }
n = expect_number(&q);
if (*q++ == 'p') {
if (sv) { /* SVf */
SvANY(dstr) = new_XNV();
SvNV_set(dstr, SvNVX(sstr));
break;
- /* case SVt_DUMMY: */
+ /* case SVt_INVLIST: */
default:
{
/* These are all the types that need complex bodies allocating. */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
- case SAVEt_RE_STATE:
- {
- const struct re_save_state *const old_state
- = (struct re_save_state *)
- (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
- struct re_save_state *const new_state
- = (struct re_save_state *)
- (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
-
- Copy(old_state, new_state, 1, struct re_save_state);
- ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
-
- new_state->re_state_bostr
- = pv_dup(old_state->re_state_bostr);
-#ifdef PERL_ANY_COW
- new_state->re_state_nrs
- = sv_dup(old_state->re_state_nrs, param);
-#endif
- new_state->re_state_reg_magic
- = (MAGIC*) any_dup(old_state->re_state_reg_magic,
- proto_perl);
- new_state->re_state_reg_oldcurpm
- = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
- proto_perl);
- new_state->re_state_reg_curpm
- = (PMOP*) any_dup(old_state->re_state_reg_curpm,
- proto_perl);
- new_state->re_state_reg_oldsaved
- = pv_dup(old_state->re_state_reg_oldsaved);
- new_state->re_state_reg_poscache
- = pv_dup(old_state->re_state_reg_poscache);
- new_state->re_state_reg_starttry
- = pv_dup(old_state->re_state_reg_starttry);
- break;
- }
case SAVEt_COMPILE_WARNINGS:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
#endif
/* RE engine related */
- Zero(&PL_reg_state, 1, struct re_save_state);
PL_regmatch_slab = NULL;
+ PL_reg_curpm = NULL;
PL_sub_generation = proto_perl->Isub_generation;
/* regex stuff */
- PL_regdummy = proto_perl->Iregdummy;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+ Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
+
/* This PV will be free'd special way so must set it same way op.c does */
PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
- PL_sortstash = hv_dup(proto_perl->Isortstash, param);
PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
https://perl5.git.perl.org / perl5.git / blobdiff