} while (0)
static SV **registry;
-static I32 regsize;
+static I32 registry_size;
#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
#define REG_REPLACE(sv,a,b) \
do { \
void* p = sv->sv_any; \
- I32 h = REGHASH(sv, regsize); \
+ I32 h = REGHASH(sv, registry_size); \
I32 i = h; \
while (registry[i] != (a)) { \
- if (++i >= regsize) \
+ if (++i >= registry_size) \
i = 0; \
if (i == h) \
die("SV registry bug"); \
reg_add(sv)
SV* sv;
{
- if (sv_count >= (regsize >> 1))
+ if (sv_count >= (registry_size >> 1))
{
SV **oldreg = registry;
- I32 oldsize = regsize;
+ I32 oldsize = registry_size;
- regsize = regsize ? ((regsize << 2) + 1) : 2037;
- Newz(707, registry, regsize, SV*);
+ registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
+ Newz(707, registry, registry_size, SV*);
if (oldreg) {
I32 i;
{
I32 i;
- for (i = 0; i < regsize; ++i) {
+ for (i = 0; i < registry_size; ++i) {
SV* sv = registry[i];
- if (sv)
+ if (sv && SvTYPE(sv) != SVTYPEMASK)
(*f)(sv);
}
}
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
SvREFCNT_dec(sv);
}
- else if (GvSV(sv))
- do_clean_objs(GvSV(sv));
}
}
#endif
sv_clean_objs(void)
{
in_clean_objs = TRUE;
+ visit(FUNC_NAME_TO_PTR(do_clean_objs));
#ifndef DISABLE_DESTRUCTOR_KLUDGE
+ /* some barnacles may yet remain, clinging to typeglobs */
visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
#endif
- visit(FUNC_NAME_TO_PTR(do_clean_objs));
in_clean_objs = FALSE;
}
STATIC XPVIV*
new_xiv(void)
{
- IV** xiv;
+ IV* xiv;
if (xiv_root) {
xiv = xiv_root;
/*
* See comment in more_xiv() -- RAM.
*/
- xiv_root = (IV**)*xiv;
+ xiv_root = *(IV**)xiv;
return (XPVIV*)((char*)xiv - sizeof(XPV));
}
return more_xiv();
STATIC void
del_xiv(XPVIV *p)
{
- IV** xiv = (IV**)((char*)(p) + sizeof(XPV));
- *xiv = (IV *)xiv_root;
+ IV* xiv = (IV*)((char*)(p) + sizeof(XPV));
+ *(IV**)xiv = xiv_root;
xiv_root = xiv;
}
STATIC XPVIV*
more_xiv(void)
{
- register IV** xiv;
- register IV** xivend;
+ register IV* xiv;
+ register IV* xivend;
XPV* ptr;
New(705, ptr, 1008/sizeof(XPV), XPV);
ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */
xiv_arenaroot = ptr; /* to keep Purify happy */
- xiv = (IV**) ptr;
- xivend = &xiv[1008 / sizeof(IV *) - 1];
- xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1; /* fudge by size of XPV */
+ xiv = (IV*) ptr;
+ xivend = &xiv[1008 / sizeof(IV) - 1];
+ xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
xiv_root = xiv;
while (xiv < xivend) {
- *xiv = (IV *)(xiv + 1);
+ *(IV**)xiv = (IV *)(xiv + 1);
xiv++;
}
- *xiv = 0;
+ *(IV**)xiv = 0;
return new_xiv();
}
else
s = SvPVX(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
- if (SvLEN(sv) && s)
+ if (SvLEN(sv) && s) {
+#ifdef MYMALLOC
+ STRLEN l = malloced_size((void*)SvPVX(sv));
+ if (newlen <= l) {
+ SvLEN_set(sv, l);
+ return s;
+ } else
+#endif
Renew(s,newlen,char);
+ }
else
New(703,s,newlen,char);
SvPV_set(sv, s);
if (!sv)
s = "NULLREF";
else {
+ MAGIC *mg;
+
switch (SvTYPE(sv)) {
+ case SVt_PVMG:
+ if ( ((SvFLAGS(sv) &
+ (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
+ == (SVs_OBJECT|SVs_RMG))
+ && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
+ && (mg = mg_find(sv, 'r'))) {
+ regexp *re = (regexp *)mg->mg_obj;
+
+ *lp = re->prelen;
+ return re->precomp;
+ }
+ /* Fall through */
case SVt_NULL:
case SVt_IV:
case SVt_NV:
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
- case SVt_PVBM:
- case SVt_PVMG: s = "SCALAR"; break;
+ case SVt_PVBM: s = "SCALAR"; break;
case SVt_PVLV: s = "LVALUE"; break;
case SVt_PVAV: s = "ARRAY"; break;
case SVt_PVHV: s = "HASH"; break;
case SVt_PVCV: s = "CODE"; break;
case SVt_PVGV: s = "GLOB"; break;
- case SVt_PVFM: s = "FORMLINE"; break;
+ case SVt_PVFM: s = "FORMAT"; break;
case SVt_PVIO: s = "IO"; break;
default: s = "UNKNOWN"; break;
}
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
+ SV *const_sv = cv_const_sv(cv);
+ bool const_changed = TRUE;
+ if(const_sv)
+ const_changed = sv_cmp(const_sv,
+ op_const_sv(CvSTART((CV*)sref),
+ Nullcv));
/* ahem, death to those who redefine
* active sort subs */
if (curstackinfo->si_type == SI_SORT &&
croak(
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
- if (cv_const_sv(cv))
- warn("Constant subroutine %s redefined",
- GvENAME((GV*)dstr));
- else if (dowarn) {
+ if (dowarn || (const_changed && const_sv)) {
if (!(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse")))
- warn("Subroutine %s redefined",
+ warn(const_sv ?
+ "Constant subroutine %s redefined"
+ : "Subroutine %s redefined",
GvENAME((GV*)dstr));
}
}
destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
if (destructor) {
ENTER;
- PUSHSTACK(SI_DESTROY);
+ PUSHSTACKi(SI_DESTROY);
SvRV(&tmpref) = SvREFCNT_inc(sv);
EXTEND(SP, 2);
PUSHMARK(SP);
perl_call_sv((SV*)GvCV(destructor),
G_DISCARD|G_EVAL|G_KEEPERR);
SvREFCNT(sv)--;
- POPSTACK();
+ POPSTACK;
LEAVE;
}
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
rsptr = NULL;
rslen = 0;
}
+ else if (RsRECORD(rs)) {
+ I32 recsize, bytesread;
+ char *buffer;
+
+ /* Grab the size of the record we're getting */
+ recsize = SvIV(SvRV(rs));
+ (void)SvPOK_only(sv); /* Validate pointer */
+ /* Make sure we've got the room to yank in the whole thing */
+ if (SvLEN(sv) <= recsize + 3) {
+ /* No, so make it bigger */
+ SvGROW(sv, recsize + 3);
+ }
+ buffer = SvPVX(sv); /* Get the location of the final buffer */
+ /* Go yank in */
+#ifdef VMS
+ /* VMS wants read instead of fread, because fread doesn't respect */
+ /* RMS record boundaries. This is not necessarily a good thing to be */
+ /* doing, but we've got no other real choice */
+ bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
+#else
+ bytesread = PerlIO_read(fp, buffer, recsize);
+#endif
+ SvCUR_set(sv, bytesread);
+ return(SvCUR(sv) ? SvPVX(sv) : Nullch);
+ }
else if (RsPARA(rs)) {
rsptr = "\n\n";
rslen = 2;
return sv;
}
-#ifdef I_STDARG
SV *
newSVpvf(const char* pat, ...)
-#else
-/*VARARGS0*/
-SV *
-newSVpvf(pat, va_alist)
-const char *pat;
-va_dcl
-#endif
{
register SV *sv;
va_list args;
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
return sv;
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
case SVt_PVGV: return "GLOB";
- case SVt_PVFM: return "FORMLINE";
+ case SVt_PVFM: return "FORMAT";
default: return "UNKNOWN";
}
}
SvSETMAGIC(sv);
}
-#ifdef I_STDARG
void
sv_setpvf(SV *sv, const char* pat, ...)
-#else
-/*VARARGS0*/
-void
-sv_setpvf(sv, pat, va_alist)
- SV *sv;
- const char *pat;
- va_dcl
-#endif
{
va_list args;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
}
-#ifdef I_STDARG
void
sv_setpvf_mg(SV *sv, const char* pat, ...)
-#else
-/*VARARGS0*/
-void
-sv_setpvf_mg(sv, pat, va_alist)
- SV *sv;
- const char *pat;
- va_dcl
-#endif
{
va_list args;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
SvSETMAGIC(sv);
}
-#ifdef I_STDARG
void
sv_catpvf(SV *sv, const char* pat, ...)
-#else
-/*VARARGS0*/
-void
-sv_catpvf(sv, pat, va_alist)
- SV *sv;
- const char *pat;
- va_dcl
-#endif
{
va_list args;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
}
-#ifdef I_STDARG
void
sv_catpvf_mg(SV *sv, const char* pat, ...)
-#else
-/*VARARGS0*/
-void
-sv_catpvf_mg(sv, pat, va_alist)
- SV *sv;
- const char *pat;
- va_dcl
-#endif
{
va_list args;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
SvSETMAGIC(sv);
projects / p5sagit/p5-mst-13.2.git / blobdiff