#define del_SV(p) \
STMT_START { \
LOCK_SV_MUTEX; \
- if (PL_debug & 32768) \
+ if (DEBUG_D_TEST) \
del_sv(p); \
else \
plant_SV(p); \
STATIC void
S_del_sv(pTHX_ SV *p)
{
- if (PL_debug & 32768) {
+ if (DEBUG_D_TEST) {
SV* sva;
SV* sv;
SV* svend;
{
/* With these two if statements:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-
+
without
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-
+
If you wish to remove them, please benchmark to see what the effect is
*/
if (u <= (UV)IV_MAX) {
{
/* With these two if statements:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-
+
without
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-
+
If you wish to remove them, please benchmark to see what the effect is
*/
if (u <= (UV)IV_MAX) {
Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
changes - now IV and NV together means that the two are interchangeable
SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
-
+
The benefit of this is operations such as pp_add know that if SvIOK is
true for both left and right operands, then integer addition can be
used instead of floating point. (for cases where the result won't
S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
if (nv_as_uv <= (UV)IV_MAX) {
(void)SvIOKp_on(sv);
(void)SvNOKp_on(sv);
#else
/* We've just lost integer precision, nothing we could do. */
SvUVX(sv) = nv_as_uv;
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
/* UV and NV slots equally valid only if we have casting symmetry. */
if (numtype & IS_NUMBER_NOT_INT) {
SvIsUV_on(sv);
STATIC int
S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
{
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
SvIsUV_on(sv);
SvUVX(sv) = U_V(SvNVX(sv));
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ if (SvUVX(sv) == UV_MAX) {
+ /* As we know that NVs don't preserve UVs, UV_MAX cannot
+ possibly be preserved by NV. Hence, it must be overflow.
+ NOK, IOKp */
+ return IS_NUMBER_OVERFLOW_UV;
+ }
SvIOK_on(sv); /* Integer is precise. NOK, UOK */
} else {
/* Integer is imprecise. NOK, IOKp */
(NV)UVX == NVX are both true, but the values differ. :-(
Hopefully for 2s complement IV_MIN is something like
0x8000000000000000 which will be exact. NWC */
- }
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
if (
(NV)UVX == NVX are both true, but the values differ. :-(
Hopefully for 2s complement IV_MIN is something like
0x8000000000000000 which will be exact. NWC */
- }
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
if (
UV u;
char *num_begin = SvPVX(sv);
int save_errno = errno;
-
+
/* seems that strtoul taking numbers that start with - is
implementation dependant, and can't be relied upon. */
if (numtype & IS_NUMBER_NEG) {
if (*num_begin == '-')
num_begin++;
}
-
+
/* Is it an integer that we could convert with strtoul?
So try it, and if it doesn't set errno then it's pukka.
This should be faster than going atof and then thinking. */
&& ((errno = 0), 1) /* always true */
&& ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
&& (errno == 0)
- /* If known to be negative, check it didn't undeflow IV
+ /* If known to be negative, check it didn't undeflow IV
XXX possibly we should put more negative values as NVs
direct rather than go via atof below */
&& ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
* LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
* do this, and vendors have had 11 years to get it right.
* However, will try to make it still work with only atol
- *
+ *
* IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
* IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
* IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
I32 numtype = 0;
I32 sawinf = 0;
STRLEN len;
+#ifdef USE_LOCALE_NUMERIC
+ bool specialradix = FALSE;
+#endif
if (SvPOK(sv)) {
sbegin = SvPVX(sv);
nbegin = s;
/*
- * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
+ * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
* integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
* possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
* will need (int)atof().
if (*s == '.'
#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
+ || (specialradix = IS_NUMERIC_RADIX(s))
#endif
) {
- s++;
+#ifdef USE_LOCALE_NUMERIC
+ if (specialradix)
+ s += SvCUR(PL_numeric_radix);
+ else
+#endif
+ s++;
numtype |= IS_NUMBER_NOT_INT;
while (isDIGIT(*s)) /* optional digits after the radix */
s++;
}
else if (*s == '.'
#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
+ || (specialradix = IS_NUMERIC_RADIX(s))
#endif
) {
- s++;
+#ifdef USE_LOCALE_NUMERIC
+ if (specialradix)
+ s += SvCUR(PL_numeric_radix);
+ else
+#endif
+ s++;
numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
/* no digits before the radix means we need digits after it */
if (isDIGIT(*s)) {
char *
Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
{
- return sv_2pv(sv,lp);
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
}
char *
=for apidoc sv_utf8_upgrade
Convert the PV of an SV to its UTF8-encoded form.
+Forces the SV to string form it it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes have hibit clear.
=cut
*/
-void
+STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
char *s, *t, *e;
int hibit = 0;
- if (!sv || !SvPOK(sv) || SvUTF8(sv))
- return;
+ if (!sv)
+ return 0;
+
+ if (!SvPOK(sv))
+ (void) SvPV_nolen(sv);
+
+ if (SvUTF8(sv))
+ return SvCUR(sv);
/* This function could be much more efficient if we had a FLAG in SVs
* to signal if there are any hibit chars in the PV.
if (hibit) {
STRLEN len;
+
if (SvREADONLY(sv) && SvFAKE(sv)) {
sv_force_normal(sv);
s = SvPVX(sv);
if (SvLEN(sv) != 0)
Safefree(s); /* No longer using what was there before. */
SvLEN(sv) = len; /* No longer know the real size. */
- SvUTF8_on(sv);
}
+ /* Mark as UTF-8 even if no hibit - saves scanning loop */
+ SvUTF8_on(sv);
+ return SvCUR(sv);
}
/*
{
if (SvPOK(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
- char *c = SvPVX(sv);
- STRLEN len = SvCUR(sv);
+ char *s;
+ STRLEN len;
- if (!utf8_to_bytes((U8*)c, &len)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
+ s = SvPV(sv, len);
+ if (!utf8_to_bytes((U8*)s, &len)) {
if (fail_ok)
return FALSE;
else {
}
SvCUR(sv) = len;
}
- SvUTF8_off(sv);
}
-
+ SvUTF8_off(sv);
return TRUE;
}
=for apidoc sv_utf8_encode
Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
-flag so that it looks like bytes again. Nothing calls this.
+flag so that it looks like octets again. Used as a building block
+for encode_utf8 in Encode.xs
=cut
*/
void
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
- sv_utf8_upgrade(sv);
+ (void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
}
+/*
+=for apidoc sv_utf8_decode
+
+Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
+turn of SvUTF8 if needed so that we see characters. Used as a building block
+for decode_utf8 in Encode.xs
+
+=cut
+*/
+
+
+
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
if (SvPOK(sv)) {
char *c;
char *e;
- bool has_utf = FALSE;
+
+ /* The octets may have got themselves encoded - get them back as bytes */
if (!sv_utf8_downgrade(sv, TRUE))
return FALSE;
&& GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
+
+#ifdef GV_SHARED_CHECK
+ if (GvSHARED((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
(void)SvOK_off(dstr);
GvINTRO_off(dstr); /* one-shot flag */
gp_free((GV*)dstr);
SV *dref = 0;
int intro = GvINTRO(dstr);
+#ifdef GV_SHARED_CHECK
+ if (GvSHARED((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
if (intro) {
GP *gp;
gp_free((GV*)dstr);
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
- SV *const_sv;
/* ahem, death to those who redefine
* active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT &&
SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
SvROK_on(dstr);
if (sflags & SVp_NOK) {
- SvNOK_on(dstr);
+ SvNOKp_on(dstr);
+ /* Only set the public OK flag if the source has public OK. */
+ if (sflags & SVf_NOK)
+ SvFLAGS(dstr) |= SVf_NOK;
SvNVX(dstr) = SvNVX(sstr);
}
if (sflags & SVp_IOK) {
- (void)SvIOK_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ (void)SvIOKp_on(dstr);
+ if (sflags & SVf_IOK)
+ SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
}
if (SvAMAGIC(sstr)) {
SvAMAGIC_on(dstr);
*SvEND(dstr) = '\0';
(void)SvPOK_only(dstr);
}
- if ((sflags & SVf_UTF8) && !IN_BYTE)
+ if (sflags & SVf_UTF8)
SvUTF8_on(dstr);
/*SUPPRESS 560*/
if (sflags & SVp_NOK) {
- SvNOK_on(dstr);
+ SvNOKp_on(dstr);
+ if (sflags & SVf_NOK)
+ SvFLAGS(dstr) |= SVf_NOK;
SvNVX(dstr) = SvNVX(sstr);
}
if (sflags & SVp_IOK) {
- (void)SvIOK_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ (void)SvIOKp_on(dstr);
+ if (sflags & SVf_IOK)
+ SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- }
- }
- else if (sflags & SVp_NOK) {
- SvNVX(dstr) = SvNVX(sstr);
- (void)SvNOK_only(dstr);
- if (sflags & SVf_IOK) {
- (void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
- /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
- if (sflags & SVf_IVisUV)
- SvIsUV_on(dstr);
}
}
else if (sflags & SVp_IOK) {
- (void)SvIOK_only(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ if (sflags & SVf_IOK)
+ (void)SvIOK_only(dstr);
+ else {
+ (void)SvOK_off(dstr);
+ (void)SvIOKp_on(dstr);
+ }
+ /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ if (sflags & SVp_NOK) {
+ if (sflags & SVf_NOK)
+ (void)SvNOK_on(dstr);
+ else
+ (void)SvNOKp_on(dstr);
+ SvNVX(dstr) = SvNVX(sstr);
+ }
+ }
+ else if (sflags & SVp_NOK) {
+ if (sflags & SVf_NOK)
+ (void)SvNOK_only(dstr);
+ else {
+ (void)SvOK_off(dstr);
+ SvNOKp_on(dstr);
+ }
+ SvNVX(dstr) = SvNVX(sstr);
}
else {
if (dtype == SVt_PVGV) {
Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
register char *dptr;
- {
- /* len is STRLEN which is unsigned, need to copy to signed */
- IV iv = len;
- assert(iv >= 0);
- }
+
SV_CHECK_THINKFIRST(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
}
+ else {
+ /* len is STRLEN which is unsigned, need to copy to signed */
+ IV iv = len;
+ assert(iv >= 0);
+ }
(void)SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
-
SvMAGIC(sv) = mg;
- if (!obj || obj == sv || how == '#' || how == 'r')
+
+ /* Some magic sontains a reference loop, where the sv and object refer to
+ each other. To prevent a avoid a reference loop that would prevent such
+ objects being freed, we look for such loops and if we find one we avoid
+ incrementing the object refcount. */
+ if (!obj || obj == sv || how == '#' || how == 'r' ||
+ (SvTYPE(obj) == SVt_PVGV &&
+ (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
+ GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
+ GvFORM(obj) == (CV*)sv)))
+ {
mg->mg_obj = obj;
+ }
else {
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
mg->mg_type = how;
mg->mg_len = namlen;
- if (name)
+ if (name) {
if (namlen >= 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ }
switch (how) {
case 0:
mg->mg_virtual = &PL_vtbl_amagicelem;
break;
case 'c':
- mg->mg_virtual = 0;
+ mg->mg_virtual = &PL_vtbl_ovrld;
break;
case 'B':
mg->mg_virtual = &PL_vtbl_bm;
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_ptr && mg->mg_type != 'g') {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ }
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
if (SvOBJECT(sv)) {
if (PL_defstash) { /* Still have a symbol table? */
- djSP;
+ dSP;
CV* destructor;
SV tmpref;
SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
SvREFCNT(&tmpref) = 1;
- do {
+ do {
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
len = 0;
while (s < send) {
STRLEN n;
-
- if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
+ /* We can use low level directly here as we are not looking at the values */
+ if (utf8n_to_uvuni(s, UTF8SKIP(s), &n, 0)) {
s += n;
len++;
}
/* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ bool is_utf8 = TRUE;
+
if (PL_hints & HINT_UTF8_DISTINCT)
return FALSE;
if (SvUTF8(sv1)) {
- (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
- {
- IV scur1 = cur1;
- if (scur1 < 0) {
- Safefree(pv1);
- return 0;
- }
- }
- pv1tmp = TRUE;
+ char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
+
+ if ((pv1tmp = (pv != pv1)))
+ pv1 = pv;
}
else {
- (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
- {
- IV scur2 = cur2;
- if (scur2 < 0) {
- Safefree(pv2);
- return 0;
- }
- }
- pv2tmp = TRUE;
+ char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
+
+ if ((pv2tmp = (pv != pv2)))
+ pv2 = pv;
}
}
if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
/* It's (privately or publicly) a float, but not tested as an
integer, so test it to see. */
- (void) SvIV(sv);
+ (void) SvIV(sv);
flags = SvFLAGS(sv);
}
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
so $a="9.22337203685478e+18"; $a+0; $a++
needs to be the same as $a="9.22337203685478e+18"; $a++
or we go insane. */
-
+
(void) sv_2iv(sv);
if (SvIOK(sv))
goto oops_its_int;
so $a="9.22337203685478e+18"; $a+0; $a--
needs to be the same as $a="9.22337203685478e+18"; $a--
or we go insane. */
-
+
(void) sv_2iv(sv);
if (SvIOK(sv))
goto oops_its_int;
len = -len;
is_utf8 = TRUE;
}
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = len;
+ /* See the note in hv.c:hv_fetch() --jhi */
+ src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+ len = tmplen;
+ }
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
char *
Perl_sv_pvbyte(pTHX_ SV *sv)
{
+ sv_utf8_downgrade(sv,0);
return sv_pv(sv);
}
char *
Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_utf8_downgrade(sv,0);
return sv_pvn(sv,lp);
}
char *
Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_utf8_downgrade(sv,0);
return sv_pvn_force(sv,lp);
}
}
/*
+=for apidoc sv_setref_uv
+
+Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+=cut
+*/
+
+SV*
+Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
+{
+ sv_setuv(newSVrv(rv,classname), uv);
+ return rv;
+}
+
+/*
=for apidoc sv_setref_nv
Copies a double into a new SV, optionally blessing the SV. The C<rv>
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
+STATIC I32
+S_expect_number(pTHX_ char** pattern)
+{
+ I32 var = 0;
+ switch (**pattern) {
+ case '1': case '2': case '3':
+ case '4': case '5': case '6':
+ case '7': case '8': case '9':
+ while (isDIGIT(**pattern))
+ var = var * 10 + (*(*pattern)++ - '0');
+ }
+ return var;
+}
+#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
+
/*
=for apidoc sv_vcatpvfn
bool alt = FALSE;
bool left = FALSE;
bool vectorize = FALSE;
- bool utf = FALSE;
+ bool vectorarg = FALSE;
+ bool vec_utf = FALSE;
char fill = ' ';
char plus = 0;
char intsize = 0;
STRLEN gap;
char *dotstr = ".";
STRLEN dotstrlen = 1;
- I32 epix = 0; /* explicit parameter index */
+ I32 efix = 0; /* explicit format parameter index */
I32 ewix = 0; /* explicit width index */
+ I32 epix = 0; /* explicit precision index */
+ I32 evix = 0; /* explicit vector index */
bool asterisk = FALSE;
+ /* echo everything up to the next format specification */
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
sv_catpvn(sv, p, q - p);
if (q++ >= patend)
break;
+/*
+ We allow format specification elements in this order:
+ \d+\$ explicit format parameter index
+ [-+ 0#]+ flags
+ \*?(\d+\$)?v vector with optional (optionally specified) arg
+ \d+|\*(\d+\$)? width using optional (optionally specified) arg
+ \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
+ [hlqLV] size
+ [%bcdefginopsux_DFOUX] format (mandatory)
+*/
+ if (EXPECT_NUMBER(q, width)) {
+ if (*q == '$') {
+ ++q;
+ efix = width;
+ } else {
+ goto gotwidth;
+ }
+ }
+
/* FLAGS */
while (*q) {
q++;
continue;
- case '*': /* printf("%*vX",":",$ipv6addr) */
- if (q[1] != 'v')
- break;
- q++;
- if (args)
- vecsv = va_arg(*args, SV*);
- else if (svix < svmax)
- vecsv = svargs[svix++];
- else
- continue;
- dotstr = SvPVx(vecsv,dotstrlen);
- if (DO_UTF8(vecsv))
- is_utf = TRUE;
- /* FALL THROUGH */
-
- case 'v':
- vectorize = TRUE;
- q++;
- continue;
-
default:
break;
}
break;
}
- /* WIDTH */
-
- scanwidth:
-
+ tryasterisk:
if (*q == '*') {
- if (asterisk)
- goto unknown;
+ q++;
+ if (EXPECT_NUMBER(q, ewix))
+ if (*q++ != '$')
+ goto unknown;
asterisk = TRUE;
+ }
+ if (*q == 'v') {
q++;
+ if (vectorize)
+ goto unknown;
+ if ((vectorarg = asterisk)) {
+ evix = ewix;
+ ewix = 0;
+ asterisk = FALSE;
+ }
+ vectorize = TRUE;
+ goto tryasterisk;
}
- switch (*q) {
- case '1': case '2': case '3':
- case '4': case '5': case '6':
- case '7': case '8': case '9':
- width = 0;
- while (isDIGIT(*q))
- width = width * 10 + (*q++ - '0');
- if (*q == '$') {
- if (asterisk && ewix == 0) {
- ewix = width;
- width = 0;
- q++;
- goto scanwidth;
- } else if (epix == 0) {
- epix = width;
- width = 0;
- q++;
- goto scanwidth;
- } else
- goto unknown;
+ if (!asterisk)
+ EXPECT_NUMBER(q, width);
+
+ if (vectorize) {
+ if (vectorarg) {
+ if (args)
+ vecsv = va_arg(*args, SV*);
+ else
+ vecsv = (evix ? evix <= svmax : svix < svmax) ?
+ svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
+ dotstr = SvPVx(vecsv, dotstrlen);
+ if (DO_UTF8(vecsv))
+ is_utf = TRUE;
+ }
+ if (args) {
+ vecsv = va_arg(*args, SV*);
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ vec_utf = DO_UTF8(vecsv);
+ }
+ else if (efix ? efix <= svmax : svix < svmax) {
+ vecsv = svargs[efix ? efix-1 : svix++];
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ vec_utf = DO_UTF8(vecsv);
+ }
+ else {
+ vecstr = (U8*)"";
+ veclen = 0;
}
}
left |= (i < 0);
width = (i < 0) ? -i : i;
}
+ gotwidth:
/* PRECISION */
if (*q == '.') {
q++;
if (*q == '*') {
+ q++;
+ if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+ goto unknown;
if (args)
i = va_arg(*args, int);
else
i = (ewix ? ewix <= svmax : svix < svmax)
? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
precis = (i < 0) ? 0 : i;
- q++;
}
else {
precis = 0;
has_precis = TRUE;
}
- if (vectorize) {
- if (args) {
- vecsv = va_arg(*args, SV*);
- vecstr = (U8*)SvPVx(vecsv,veclen);
- utf = DO_UTF8(vecsv);
- }
- else if (epix ? epix <= svmax : svix < svmax) {
- vecsv = svargs[epix ? epix-1 : svix++];
- vecstr = (U8*)SvPVx(vecsv,veclen);
- utf = DO_UTF8(vecsv);
- }
- else {
- vecstr = (U8*)"";
- veclen = 0;
- }
- }
-
/* SIZE */
switch (*q) {
/* CONVERSION */
+ if (*q == '%') {
+ eptr = q++;
+ elen = 1;
+ goto string;
+ }
+
+ if (!args)
+ argsv = (efix ? efix <= svmax : svix < svmax) ?
+ svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
+
switch (c = *q++) {
/* STRINGS */
- case '%':
- eptr = q - 1;
- elen = 1;
- goto string;
-
case 'c':
- if (args)
- uv = va_arg(*args, int);
- else
- uv = (epix ? epix <= svmax : svix < svmax) ?
- SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
+ uv = args ? va_arg(*args, int) : SvIVx(argsv);
if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
eptr = (char*)utf8buf;
- elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
+ elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
}
else {
elen = sizeof nullstr - 1;
}
}
- else if (epix ? epix <= svmax : svix < svmax) {
- argsv = svargs[epix ? epix-1 : svix++];
+ else {
eptr = SvPVx(argsv, elen);
if (DO_UTF8(argsv)) {
if (has_precis && precis < elen) {
*/
if (!args)
goto unknown;
- argsv = va_arg(*args,SV*);
+ argsv = va_arg(*args, SV*);
eptr = SvPVx(argsv, elen);
if (DO_UTF8(argsv))
is_utf = TRUE;
case 'p':
if (alt)
goto unknown;
- if (args)
- uv = PTR2UV(va_arg(*args, void*));
- else
- uv = (epix ? epix <= svmax : svix < svmax) ?
- PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
+ uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
base = 16;
goto integer;
case 'i':
if (vectorize) {
STRLEN ulen;
- if (!veclen) {
- vectorize = FALSE;
- break;
- }
- if (utf)
- iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
+ if (!veclen)
+ continue;
+ if (vec_utf)
+ iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
else {
iv = *vecstr;
ulen = 1;
}
}
else {
- iv = (epix ? epix <= svmax : svix < svmax) ?
- SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
+ iv = SvIVx(argsv);
switch (intsize) {
case 'h': iv = (short)iv; break;
default: break;
if (vectorize) {
STRLEN ulen;
vector:
- if (!veclen) {
- vectorize = FALSE;
- break;
- }
- if (utf)
- uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
+ if (!veclen)
+ continue;
+ if (vec_utf)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
else {
uv = *vecstr;
ulen = 1;
}
}
else {
- uv = (epix ? epix <= svmax : svix < svmax) ?
- SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
+ uv = SvUVx(argsv);
switch (intsize) {
case 'h': uv = (unsigned short)uv; break;
default: break;
/* This is evil, but floating point is even more evil */
vectorize = FALSE;
- if (args)
- nv = va_arg(*args, NV);
- else
- nv = (epix ? epix <= svmax : svix < svmax) ?
- SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
+ nv = args ? va_arg(*args, NV) : SvNVx(argsv);
need = 0;
if (c != 'e' && c != 'E') {
#endif
}
}
- else if (epix ? epix <= svmax : svix < svmax)
- sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
+ else
+ sv_setuv_mg(argsv, (UV)i);
continue; /* not "break" */
/* UNKNOWN */
/* ... right here, because formatting flags should not apply */
SvGROW(sv, SvCUR(sv) + elen + 1);
p = SvEND(sv);
- memcpy(p, eptr, elen);
+ Copy(eptr, p, elen, char);
p += elen;
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
*p++ = '0';
}
if (elen) {
- memcpy(p, eptr, elen);
+ Copy(eptr, p, elen, char);
p += elen;
}
if (gap && left) {
}
if (vectorize) {
if (veclen) {
- memcpy(p, dotstr, dotstrlen);
+ Copy(dotstr, p, dotstrlen, char);
p += dotstrlen;
}
else
}
}
+void
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+{
+ register PTR_TBL_ENT_t **array;
+ register PTR_TBL_ENT_t *entry;
+ register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
+ UV riter = 0;
+ UV max;
+
+ if (!tbl || !tbl->tbl_items) {
+ return;
+ }
+
+ array = tbl->tbl_ary;
+ entry = array[0];
+ max = tbl->tbl_max;
+
+ for (;;) {
+ if (entry) {
+ oentry = entry;
+ entry = entry->next;
+ Safefree(oentry);
+ }
+ if (!entry) {
+ if (++riter > max) {
+ break;
+ }
+ entry = array[riter];
+ }
+ }
+
+ tbl->tbl_items = 0;
+}
+
+void
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+{
+ if (!tbl) {
+ return;
+ }
+ ptr_table_clear(tbl);
+ Safefree(tbl->tbl_ary);
+ Safefree(tbl);
+}
+
#ifdef DEBUGGING
char *PL_watch_pvx;
#endif
+STATIC SV *
+S_gv_share(pTHX_ SV *sstr)
+{
+ GV *gv = (GV*)sstr;
+ SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+
+ if (GvIO(gv) || GvFORM(gv)) {
+ GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
+ }
+ else if (!GvCV(gv)) {
+ GvCV(gv) = (CV*)sv;
+ }
+ else {
+ /* CvPADLISTs cannot be shared */
+ if (!CvXSUB(GvCV(gv))) {
+ GvSHARED_off(gv);
+ }
+ }
+
+ if (!GvSHARED(gv)) {
+#if 0
+ PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
+ HvNAME(GvSTASH(gv)), GvNAME(gv));
+#endif
+ return Nullsv;
+ }
+
+ /*
+ * write attempts will die with
+ * "Modification of a read-only value attempted"
+ */
+ if (!GvSV(gv)) {
+ GvSV(gv) = sv;
+ }
+ else {
+ SvREADONLY_on(GvSV(gv));
+ }
+
+ if (!GvAV(gv)) {
+ GvAV(gv) = (AV*)sv;
+ }
+ else {
+ SvREADONLY_on(GvAV(gv));
+ }
+
+ if (!GvHV(gv)) {
+ GvHV(gv) = (HV*)sv;
+ }
+ else {
+ SvREADONLY_on(GvAV(gv));
+ }
+
+ return sstr; /* he_dup() will SvREFCNT_inc() */
+}
+
SV *
Perl_sv_dup(pTHX_ SV *sstr)
{
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
+ if (GvSHARED((GV*)sstr)) {
+ SV *share;
+ if ((share = gv_share(sstr))) {
+ del_SV(dstr);
+ dstr = share;
+#if 0
+ PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
+ HvNAME(GvSTASH(share)), GvNAME(share));
+#endif
+ break;
+ }
+ }
SvANY(dstr) = new_XPVGV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
}
else
CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
- CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
+ if (!CvANON(sstr) || CvCLONED(sstr))
+ CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
+ else
+ CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
CvFLAGS(dstr) = CvFLAGS(sstr);
break;
default:
PL_scopestack = 0;
PL_savestack = 0;
PL_retstack = 0;
+ PL_sig_pending = 0;
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
PL_scopestack = 0;
PL_savestack = 0;
PL_retstack = 0;
+ PL_sig_pending = 0;
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
- PL_numeric_radix = proto_perl->Inumeric_radix;
+ PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
+ if (proto_perl->Ipsig_pend) {
+ Newz(0, PL_psig_pend, SIG_SIZE, int);
+ }
+ else {
+ PL_psig_pend = (int*)NULL;
+ }
+
if (proto_perl->Ipsig_ptr) {
- int sig_num[] = { SIG_NUM };
- Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
- Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
- for (i = 1; PL_sig_name[i]; i++) {
- PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
+ Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
+ Newz(0, PL_psig_name, SIG_SIZE, SV*);
+ for (i = 1; i < SIG_SIZE; i++) {
+ PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
}
}
/* thrdvar.h stuff */
- if (flags & 1) {
+ if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
PL_tmps_ix = proto_perl->Ttmps_ix;
PL_tmps_max = proto_perl->Ttmps_max;
PL_reginterp_cnt = 0;
PL_reg_starttry = 0;
+ if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
+ }
+
#ifdef PERL_OBJECT
return (PerlInterpreter*)pPerl;
#else
https://perl5.git.perl.org / perl5.git / blobdiff