do_clean_objs(pTHX_ SV *ref)
{
dVAR;
- if (SvROK(ref)) {
+ assert (SvROK(ref));
+ {
SV * const target = SvRV(ref);
if (SvOBJECT(target)) {
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
do_clean_named_objs(pTHX_ SV *sv)
{
dVAR;
- if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) {
+ assert(SvTYPE(sv) == SVt_PVGV);
+ assert(isGV_with_GP(sv));
+ if (GvGP(sv)) {
if ((
#ifdef PERL_DONT_CREATE_GVSV
GvSV(sv) &&
visit(do_clean_objs, SVf_ROK, SVf_ROK);
#ifndef DISABLE_DESTRUCTOR_KLUDGE
/* some barnacles may yet remain, clinging to typeglobs */
- visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
+ visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
#endif
PL_in_clean_objs = FALSE;
}
TBD: export properly for hv.c: S_more_he().
*/
void*
-Perl_get_arena(pTHX_ int arena_size)
+Perl_get_arena(pTHX_ size_t arena_size)
{
dVAR;
struct arena_desc* adesc;
adesc = &((*aroot)->set[curr]);
assert(!adesc->arena);
- Newxz(adesc->arena, arena_size, char);
+ Newx(adesc->arena, arena_size, char);
adesc->size = arena_size;
DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n",
- curr, adesc->arena, arena_size));
+ curr, (void*)adesc->arena, arena_size));
return adesc->arena;
}
#define new_NOARENAZ(details) \
my_safecalloc((details)->body_size + (details)->offset)
-#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
-static bool done_sanity_check;
-#endif
-
STATIC void *
S_more_bodies (pTHX_ svtype sv_type)
{
const size_t body_size = bdp->body_size;
char *start;
const char *end;
-
- assert(bdp->arena_size);
-
#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
+ static bool done_sanity_check;
+
/* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
* variables like done_sanity_check. */
if (!done_sanity_check) {
}
#endif
+ assert(bdp->arena_size);
+
start = (char*) Perl_get_arena(aTHX_ bdp->arena_size);
end = start + bdp->arena_size - body_size;
/* computed count doesnt reflect the 1st slot reservation */
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d type %d size %d ct %d\n",
- start, end,
+ (void*)start, (void*)end,
(int)bdp->arena_size, sv_type, (int)body_size,
(int)bdp->arena_size / (int)body_size));
(In fact, GP ends up pointing at a previous GP structure, because the
principle cause of the padding in XPVMG getting garbage is a copy of
- sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
+ sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
+ this happens to be moot because XPVGV has been re-ordered, with GP
+ no longer after STASH)
So we are careful and work out the size of used parts of all the
structures. */
if (dtype != SVt_PVGV) {
const char * const name = GvNAME(sstr);
const STRLEN len = GvNAMELEN(sstr);
- /* don't upgrade SVt_PVLV: it can hold a glob */
- if (dtype != SVt_PVLV) {
+ {
if (dtype >= SVt_PV) {
SvPV_free(dstr);
SvPV_set(dstr, 0);
SvLEN_set(dstr, 0);
SvCUR_set(dstr, 0);
}
- sv_upgrade(dstr, SVt_PVGV);
+ SvUPGRADE(dstr, SVt_PVGV);
(void)SvOK_off(dstr);
/* FIXME - why are we doing this, then turning it off and on again
below? */
if (SvIS_FREED(dstr)) {
Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
- " to a freed scalar %p", sstr, dstr);
+ " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
}
SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (!sstr)
sstr = &PL_sv_undef;
if (SvIS_FREED(sstr)) {
- Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr,
- dstr);
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
+ (void*)sstr, (void*)dstr);
}
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
break;
/* case SVt_BIND: */
+ case SVt_PVLV:
case SVt_PVGV:
if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
glob_assign_glob(dstr, sstr, dtype);
/*FALLTHROUGH*/
case SVt_PVMG:
- case SVt_PVLV:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype) {
dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
- if (dtype == SVt_PVCV) {
+ if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
/* Assigning to a subroutine sets the prototype. */
if (SvOK(sstr)) {
STRLEN len;
Copy(ptr, SvPVX(dstr), len + 1, char);
SvCUR_set(dstr, len);
SvPOK_only(dstr);
+ SvFLAGS(dstr) |= sflags & SVf_UTF8;
} else {
SvOK_off(dstr);
}
+ } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
+ const char * const type = sv_reftype(dstr,0);
+ if (PL_op)
+ Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
+ else
+ Perl_croak(aTHX_ "Cannot copy to %s", type);
} else if (sflags & SVf_ROK) {
if (isGV_with_GP(dstr) && dtype == SVt_PVGV
&& SvTYPE(SvRV(sstr)) == SVt_PVGV) {
SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
- SvRELEASE_IVX(dstr);
+ SvOOK_off(dstr);
SvIV_set(dstr, SvIVX(sstr));
/* Must do this otherwise some other overloaded use of 0x80000000
gets confused. I guess SVpbm_VALID */
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
- sstr, dstr);
+ (void*)sstr, (void*)dstr);
sv_dump(sstr);
if (dstr)
sv_dump(dstr);
(which it can do by means other than releasing copy-on-write Svs)
or by changing the other copy-on-write SVs in the loop. */
STATIC void
-S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
+S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
{
- if (len) { /* this SV was SvIsCOW_normal(sv) */
+ { /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
SV *current = SV_COW_NEXT_SV(after);
/* Make the SV before us point to the SV after us. */
SV_COW_NEXT_SV_SET(current, after);
}
- } else {
- unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
}
-
-int
-Perl_sv_release_IVX(pTHX_ register SV *sv)
-{
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
- SvOOK_off(sv);
- return 0;
-}
#endif
/*
=for apidoc sv_force_normal_flags
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvLEN(sv);
const STRLEN cur = SvCUR(sv);
- SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
+ /* next COW sv in the loop. If len is 0 then this is a shared-hash
+ key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
+ we'll fail an assertion. */
+ SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: Force normal %ld\n",
SvCUR_set(sv, cur);
*SvEND(sv) = '\0';
}
- sv_release_COW(sv, pvx, len, next);
+ if (len) {
+ sv_release_COW(sv, pvx, next);
+ } else {
+ unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
+ }
if (DEBUG_C_TEST) {
sv_dump(sv);
}
case PERL_MAGIC_regdata:
vtable = &PL_vtbl_regdata;
break;
- case PERL_MAGIC_regdata_names:
- vtable = &PL_vtbl_regdata_names;
- break;
case PERL_MAGIC_regdatum:
vtable = &PL_vtbl_regdatum;
break;
}
if (type >= SVt_PVMG) {
if (type == SVt_PVMG && SvPAD_OUR(sv)) {
- SvREFCNT_dec(OURSTASH(sv));
+ SvREFCNT_dec(SvOURSTASH(sv));
} else if (SvMAGIC(sv))
mg_free(sv);
if (type == SVt_PVMG && SvPAD_TYPED(sv))
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
- goto freescalar;
case SVt_PVGV:
if (isGV_with_GP(sv)) {
gp_free((GV*)sv);
PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
sv_dump(sv);
}
- sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
- SV_COW_NEXT_SV(sv));
+ if (SvLEN(sv)) {
+ sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
+ } else {
+ unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
+ }
+
/* And drop it here. */
SvFAKE_off(sv);
} else if (SvLEN(sv)) {
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
" real %"UVuf" for %"SVf,
- (UV) ulen, (UV) real, (void*)sv);
+ (UV) ulen, (UV) real, SVfARG(sv));
}
}
}
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
" real %"UVuf" for %"SVf,
- (UV) boffset, (UV) real_boffset, (void*)sv);
+ (UV) boffset, (UV) real_boffset, SVfARG(sv));
}
}
boffset = real_boffset;
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
- " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv);
+ " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
}
}
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
" real %"UVuf" for %"SVf,
- (UV) len, (UV) real_len, (void*)sv);
+ (UV) len, (UV) real_len, SVfARG(sv));
}
}
len = real_len;
else
io = 0;
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv);
+ Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
break;
}
return io;
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- (void*)sv);
+ SVfARG(sv));
}
return GvCVu(gv);
}
}
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
- argsv = va_arg(*args, SV*);
+ argsv = (SV*)va_arg(*args, void*);
sv_catsv(sv, argsv);
return;
}
precis = n;
has_precis = TRUE;
}
- argsv = va_arg(*args, SV*);
+ argsv = (SV*)va_arg(*args, void*);
eptr = SvPVx_const(argsv, elen);
if (DO_UTF8(argsv))
is_utf8 = TRUE;
(UV)c & 0xFF);
} else
sv_catpvs(msg, "end of string");
- Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
}
/* output mangled stuff ... */
if (!proto)
return NULL;
+ /* look for it in the table first */
+ parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
+ if (parser)
+ return parser;
+
+ /* create anew and remember what it is */
Newxz(parser, 1, yy_parser);
+ ptr_table_store(PL_ptr_table, proto, parser);
parser->yyerrstatus = 0;
parser->yychar = YYEMPTY; /* Cause a token to be read. */
return mgret;
}
+#endif /* USE_ITHREADS */
+
/* create a new pointer-mapping table */
PTR_TBL_t *
Safefree(tbl);
}
+#if defined(USE_ITHREADS)
void
Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
#ifdef DEBUGGING
if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
- PL_watch_pvx, SvPVX_const(sstr));
+ (void*)PL_watch_pvx, SvPVX_const(sstr));
#endif
/* don't clone objects whose class has asked us not to */
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
- OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param));
+ SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvSTASH(dstr))
LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
- break;
case SVt_PVGV:
if(isGV_with_GP(sstr)) {
if (GvNAME_HEK(dstr))
GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
- }
-
- /* Don't call sv_add_backref here as it's going to be created
- as part of the magic cloning of the symbol table. */
- if(!SvVALID(dstr))
- GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
- if(isGV_with_GP(sstr)) {
+ /* Don't call sv_add_backref here as it's going to be
+ created as part of the magic cloning of the symbol
+ table. */
/* Danger Will Robinson - GvGP(dstr) isn't initialised
at the point of this comment. */
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
} else
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
break;
+ case SAVEt_PARSER:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = parser_dup(ptr, param);
+ break;
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
newSViv(PTR2IV(CALLREGDUPE(
INT2PTR(REGEXP *, SvIVX(regex)), param))))
;
+ if (SvFLAGS(regex) & SVf_BREAK)
+ SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */
av_push(PL_regex_padav, sv);
}
}
projects / p5sagit/p5-mst-13.2.git / blobdiff