editing it in the perl core. */
#ifndef PERL_CORE
+# define PERL_NO_GET_CONTEXT
# include "EXTERN.h"
# include "perl.h"
# include "XSUB.h"
#define VERSION_MAX 0x7FFFFFFF
/*
+=head1 Versioning
+
=for apidoc prescan_version
Validate that a given string can be parsed as a version object, but doesn't
=cut
*/
const char *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_prescan_version2(pTHX_ const char *s, bool strict,
#else
Perl_prescan_version(pTHX_ const char *s, bool strict,
*/
const char *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
#else
Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
if (errstr) {
/* "undef" is a special case and not an error */
- if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
- Safefree(start);
+ if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
Perl_croak(aTHX_ "%s", errstr);
}
}
}
}
if ( qv ) { /* quoted versions always get at least three terms*/
- SSize_t len = av_len(av);
+ SSize_t len = AvFILLp(av);
/* This for loop appears to trigger a compiler bug on OS X, as it
loops infinitely. Yes, len is negative. No, it makes no sense.
Compiler in question is:
(void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
/* fix RT#19517 - special case 'undef' as string */
- if ( *s == 'u' && strEQ(s,"undef") ) {
+ if ( *s == 'u' && strEQ(s+1,"ndef") ) {
s += 5;
}
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_new_version2(pTHX_ SV *ver)
#else
Perl_new_version(pTHX_ SV *ver)
dVAR;
SV * const rv = newSV(0);
PERL_ARGS_ASSERT_NEW_VERSION;
- if ( ISA_CLASS_OBJ(ver,"version") ) /* can just copy directly */
+ if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
{
SSize_t key;
AV * const av = newAV();
if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-
- if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
{
- const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
- (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+ SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
+ if(svp) {
+ const I32 width = SvIV(*svp);
+ (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+ }
}
-
- if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
{
- SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
- (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
+ SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+ if(svp)
+ (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
}
-
sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
/* This will get reblessed later if a derived class*/
for ( key = 0; key <= av_len(sav); key++ )
{
- const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
+ SV * const sv = *av_fetch(sav, key, FALSE);
+ const I32 rev = SvIV(sv);
av_push(av, newSViv(rev));
}
const MAGIC* const mg = SvVSTRING_mg(ver);
if ( mg ) { /* already a v-string */
const STRLEN len = mg->mg_len;
- char * const version = savepvn( (const char*)mg->mg_ptr, len);
+ const char * const version = (const char*)mg->mg_ptr;
sv_setpvn(rv,version,len);
/* this is for consistency with the pure Perl class */
if ( isDIGIT(*version) )
sv_insert(rv, 0, 0, "v", 1);
- Safefree(version);
}
else {
#endif
}
}
#endif
- return UPG_VERSION(rv, FALSE);
+ sv_2mortal(rv); /* in case upg_version croaks before it returns */
+ return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE));
}
/*
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_upg_version2(pTHX_ SV *ver, bool qv)
#else
Perl_upg_version(pTHX_ SV *ver, bool qv)
const MAGIC *mg;
#endif
+#if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
+ ENTER;
+#endif
PERL_ARGS_ASSERT_UPG_VERSION;
- if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
+ if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
+ || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
+ /* out of bounds [unsigned] integer */
+ STRLEN len;
+ char tbuf[64];
+ len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
+ version = savepvn(tbuf, len);
+ SAVEFREEPV(version);
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version %d",VERSION_MAX);
+ }
+ else if ( SvUOK(ver) || SvIOK(ver))
+#if PERL_VERSION_LT(5,17,2)
+VER_IV:
+#endif
+ {
+ version = savesvpv(ver);
+ SAVEFREEPV(version);
+ }
+ else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
+#if PERL_VERSION_LT(5,17,2)
+VER_NV:
+#endif
{
STRLEN len;
char tbuf[64];
SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
char *buf;
+#ifdef USE_LOCALE_NUMERIC
+ const char * const cur_numeric = setlocale(LC_NUMERIC, NULL);
+ assert(cur_numeric);
+
+ /* XS code can set the locale without us knowing. To protect the
+ * version number parsing, which requires the radix character to be a
+ * dot, update our records as to what the locale is, so that our
+ * existing macro mechanism can correctly change it to a dot and back
+ * if necessary. This code is extremely unlikely to be in a loop, so
+ * the extra work will have a negligible performance impact. See [perl
+ * #121930].
+ *
+ * If the current locale is a standard one, but we are expecting it to
+ * be a different, underlying locale, update our records to make the
+ * underlying locale this (standard) one. If the current locale is not
+ * a standard one, we should be expecting a non-standard one, the same
+ * one that we have recorded as the underlying locale. If not, update
+ * our records. */
+ if (strEQ(cur_numeric, "C") || strEQ(cur_numeric, "POSIX")) {
+ if (! PL_numeric_standard) {
+ new_numeric(cur_numeric);
+ }
+ }
+ else if (PL_numeric_standard
+ || ! PL_numeric_name
+ || strNE(PL_numeric_name, cur_numeric))
+ {
+ new_numeric(cur_numeric);
+ }
+#endif
+ { /* Braces needed because macro just below declares a variable */
STORE_NUMERIC_LOCAL_SET_STANDARD();
+ LOCK_NUMERIC_STANDARD();
if (sv) {
Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
len = SvCUR(sv);
len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
buf = tbuf;
}
+ UNLOCK_NUMERIC_STANDARD();
RESTORE_NUMERIC_LOCAL();
+ }
while (buf[len-1] == '0' && len > 0) len--;
if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
version = savepvn(buf, len);
+ SAVEFREEPV(version);
SvREFCNT_dec(sv);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+ SAVEFREEPV(version);
qv = TRUE;
}
#endif
- else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
- || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
- /* out of bounds [unsigned] integer */
- STRLEN len;
- char tbuf[64];
- len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
- version = savepvn(tbuf, len);
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version %d",VERSION_MAX);
- }
- else if ( SvUOK(ver) || SvIOK(ver) ) {
- version = savesvpv(ver);
- }
- else if ( SvPOK(ver) )/* must be a string or something like a string */
+ else if ( SvPOK(ver))/* must be a string or something like a string */
+#if PERL_VERSION_LT(5,17,2)
+VER_PV:
+#endif
{
STRLEN len;
version = savepvn(SvPV(ver,len), SvCUR(ver));
+ SAVEFREEPV(version);
#ifndef SvVOK
# if PERL_VERSION > 5
/* This will only be executed for 5.6.0 - 5.8.0 inclusive */
int saw_decimal = 0;
sv_setpvf(nsv,"v%vd",ver);
pos = nver = savepv(SvPV_nolen(nsv));
+ SAVEFREEPV(pos);
/* scan the resulting formatted string */
pos++; /* skip the leading 'v' */
/* is definitely a v-string */
if ( saw_decimal >= 2 ) {
- Safefree(version);
version = nver;
}
break;
# endif
#endif
}
+#if PERL_VERSION_LT(5,17,2)
+ else if (SvIOKp(ver)) {
+ goto VER_IV;
+ }
+ else if (SvNOKp(ver)) {
+ goto VER_NV;
+ }
+ else if (SvPOKp(ver)) {
+ goto VER_PV;
+ }
+#endif
else
{
/* no idea what this is */
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Version string '%s' contains invalid data; "
"ignoring: '%s'", version, s);
- Safefree(version);
+
+#if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
+ LEAVE;
+#endif
+
return ver;
}
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vverify2(pTHX_ SV *vs)
#else
Perl_vverify(pTHX_ SV *vs)
#endif
{
SV *sv;
+ SV **svp;
PERL_ARGS_ASSERT_VVERIFY;
/* see if the appropriate elements exist */
if ( SvTYPE(vs) == SVt_PVHV
- && hv_exists(MUTABLE_HV(vs), "version", 7)
- && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
+ && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
+ && (sv = SvRV(*svp))
&& SvTYPE(sv) == SVt_PVAV )
return vs;
else
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vnumify2(pTHX_ SV *vs)
#else
Perl_vnumify(pTHX_ SV *vs)
/* see if various flags exist */
if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
alpha = TRUE;
- if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
- width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
- else
- width = 3;
+ {
+ SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
+ if ( svp )
+ width = SvIV(*svp);
+ else
+ width = 3;
+ }
/* attempt to retrieve the version array */
return newSVpvs("0");
}
- digit = SvIV(*av_fetch(av, 0, 0));
+ {
+ SV * tsv = *av_fetch(av, 0, 0);
+ digit = SvIV(tsv);
+ }
sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i < len ; i++ )
{
- digit = SvIV(*av_fetch(av, i, 0));
+ SV * tsv = *av_fetch(av, i, 0);
+ digit = SvIV(tsv);
if ( width < 3 ) {
const int denom = (width == 2 ? 10 : 100);
const div_t term = div((int)PERL_ABS(digit),denom);
if ( len > 0 )
{
- digit = SvIV(*av_fetch(av, len, 0));
+ SV * tsv = *av_fetch(av, len, 0);
+ digit = SvIV(tsv);
if ( alpha && width == 3 ) /* alpha version */
sv_catpvs(sv,"_");
Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vnormal2(pTHX_ SV *vs)
#else
Perl_vnormal(pTHX_ SV *vs)
{
return newSVpvs("");
}
- digit = SvIV(*av_fetch(av, 0, 0));
+ {
+ SV * tsv = *av_fetch(av, 0, 0);
+ digit = SvIV(tsv);
+ }
sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
for ( i = 1 ; i < len ; i++ ) {
- digit = SvIV(*av_fetch(av, i, 0));
+ SV * tsv = *av_fetch(av, i, 0);
+ digit = SvIV(tsv);
Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
}
if ( len > 0 )
{
/* handle last digit specially */
- digit = SvIV(*av_fetch(av, len, 0));
+ SV * tsv = *av_fetch(av, len, 0);
+ digit = SvIV(tsv);
if ( alpha )
Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
else
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vstringify2(pTHX_ SV *vs)
#else
Perl_vstringify(pTHX_ SV *vs)
#endif
{
+ SV ** svp;
PERL_ARGS_ASSERT_VSTRINGIFY;
/* extract the HV from the object */
if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
- if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
+ svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+ if (svp) {
SV *pv;
- pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+ pv = *svp;
if ( SvPOK(pv) )
return newSVsv(pv);
else
*/
int
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
#else
Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
i = 0;
while ( i <= m && retval == 0 )
{
- left = SvIV(*av_fetch(lav,i,0));
- right = SvIV(*av_fetch(rav,i,0));
+ SV * const lsv = *av_fetch(lav,i,0);
+ SV * rsv;
+ left = SvIV(lsv);
+ rsv = *av_fetch(rav,i,0);
+ right = SvIV(rsv);
if ( left < right )
retval = -1;
if ( left > right )
{
while ( i <= r && retval == 0 )
{
- if ( SvIV(*av_fetch(rav,i,0)) != 0 )
+ SV * const rsv = *av_fetch(rav,i,0);
+ if ( SvIV(rsv) != 0 )
retval = -1; /* not a match after all */
i++;
}
{
while ( i <= l && retval == 0 )
{
- if ( SvIV(*av_fetch(lav,i,0)) != 0 )
+ SV * const lsv = *av_fetch(lav,i,0);
+ if ( SvIV(lsv) != 0 )
retval = +1; /* not a match after all */
i++;
}
https://perl5.git.perl.org / perl5.git / blobdiff