From 05402f6b212ae526674299c1c22151299db21ebb Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sun, 12 Jan 2014 11:19:53 -0500 Subject: Lots of C optimizations for both speed/correctness Clean up a lot of the less efficient uses of various Perl macros and functions, mostly from bulk88@hotmail.com. Also deal with the fact that older Perl's were not handling locale setting in a consistent manner. This means going back to the less efficient but always correct method of ALWAYS copying the old locale and switch to C and then restoring, for all Perl releases prior to 5.19.0. Discontinue support for Perl's prior to v5.6.2. --- cpan/version/lib/version.pm | 4 +- cpan/version/lib/version/regex.pm | 2 +- cpan/version/lib/version/vpp.pm | 25 +++--- cpan/version/t/00impl-pp.t | 2 +- cpan/version/t/01base.t | 2 +- cpan/version/t/02derived.t | 2 +- cpan/version/t/03require.t | 2 +- cpan/version/t/05sigdie.t | 2 +- cpan/version/t/06noop.t | 2 +- cpan/version/t/07locale.t | 2 +- cpan/version/t/08_corelist.t | 2 +- cpan/version/t/09_list_util.t | 2 +- vutil.c | 100 +++++++++++++++--------- vutil.h | 64 ++++++++++++++- vxs.inc | 159 +++++++++++++++++++------------------- 15 files changed, 232 insertions(+), 140 deletions(-) diff --git a/cpan/version/lib/version.pm b/cpan/version/lib/version.pm index e20fb6e1a5..280c8595f4 100644 --- a/cpan/version/lib/version.pm +++ b/cpan/version/lib/version.pm @@ -1,12 +1,12 @@ #!perl -w package version; -use 5.005_04; +use 5.006002; use strict; use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); -$VERSION = 0.9906; +$VERSION = 0.9907; $CLASS = 'version'; # avoid using Exporter diff --git a/cpan/version/lib/version/regex.pm b/cpan/version/lib/version/regex.pm index 341902e670..1c8f6e1849 100644 --- a/cpan/version/lib/version/regex.pm +++ b/cpan/version/lib/version/regex.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION $CLASS $STRICT $LAX); -$VERSION = 0.9906; +$VERSION = 0.9907; #--------------------------------------------------------------------------# # Version regexp components diff --git a/cpan/version/lib/version/vpp.pm b/cpan/version/lib/version/vpp.pm index 13e5a7eacb..76b9119eb0 100644 --- a/cpan/version/lib/version/vpp.pm +++ b/cpan/version/lib/version/vpp.pm @@ -117,13 +117,12 @@ sub currstr { package version::vpp; -use 5.005_04; +use 5.006002; use strict; -use POSIX qw/locale_h/; -use locale; +use Config; use vars qw($VERSION $CLASS @ISA $LAX $STRICT); -$VERSION = 0.9906; +$VERSION = 0.9907; $CLASS = 'version::vpp'; require version::regex; @@ -479,7 +478,7 @@ sub scan_version { if ($errstr) { # 'undef' is a special case and not an error if ( $s ne 'undef') { - use Carp; + require Carp; Carp::croak($errstr); } } @@ -654,13 +653,17 @@ sub new return $self; } - my $currlocale = setlocale(LC_ALL); + if ($Config{d_setlocale}) { + use POSIX qw/locale_h/; + use if $Config{d_setlocale}, 'locale'; + my $currlocale = setlocale(LC_ALL); - # if the current locale uses commas for decimal points, we - # just replace commas with decimal places, rather than changing - # locales - if ( localeconv()->{decimal_point} eq ',' ) { - $value =~ tr/,/./; + # if the current locale uses commas for decimal points, we + # just replace commas with decimal places, rather than changing + # locales + if ( localeconv()->{decimal_point} eq ',' ) { + $value =~ tr/,/./; + } } if ( not defined $value or $value =~ /^undef$/ ) { diff --git a/cpan/version/t/00impl-pp.t b/cpan/version/t/00impl-pp.t index c62889fa79..836a75aa5f 100644 --- a/cpan/version/t/00impl-pp.t +++ b/cpan/version/t/00impl-pp.t @@ -9,7 +9,7 @@ use Test::More qw/no_plan/; BEGIN { (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; require $coretests; - use_ok('version::vpp', 0.9906); + use_ok('version::vpp', 0.9907); } BaseTests("version::vpp","new","qv"); diff --git a/cpan/version/t/01base.t b/cpan/version/t/01base.t index 41ba0f69fb..3c7edcf5c7 100644 --- a/cpan/version/t/01base.t +++ b/cpan/version/t/01base.t @@ -9,7 +9,7 @@ use Test::More qw/no_plan/; BEGIN { (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; require $coretests; - use_ok('version', 0.9906); + use_ok('version', 0.9907); } BaseTests("version","new","qv"); diff --git a/cpan/version/t/02derived.t b/cpan/version/t/02derived.t index 9f2f97e043..5bd443758b 100644 --- a/cpan/version/t/02derived.t +++ b/cpan/version/t/02derived.t @@ -10,7 +10,7 @@ use File::Temp qw/tempfile/; BEGIN { (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; require $coretests; - use_ok("version", 0.9906); + use_ok("version", 0.9907); # If we made it this far, we are ok. } diff --git a/cpan/version/t/03require.t b/cpan/version/t/03require.t index d480c886c8..48ddcd6d8a 100644 --- a/cpan/version/t/03require.t +++ b/cpan/version/t/03require.t @@ -14,7 +14,7 @@ BEGIN { # Don't want to use, because we need to make sure that the import doesn't # fire just yet (some code does this to avoid importing qv() and delare()). require_ok("version"); -is $version::VERSION, 0.9906, "Make sure we have the correct class"; +is $version::VERSION, 0.9907, "Make sure we have the correct class"; ok(!"main"->can("qv"), "We don't have the imported qv()"); ok(!"main"->can("declare"), "We don't have the imported declare()"); diff --git a/cpan/version/t/05sigdie.t b/cpan/version/t/05sigdie.t index 5fe52108f1..a145450472 100644 --- a/cpan/version/t/05sigdie.t +++ b/cpan/version/t/05sigdie.t @@ -14,7 +14,7 @@ BEGIN { } BEGIN { - use version 0.9906; + use version 0.9907; } pass "Didn't get caught by the wrong DIE handler, which is a good thing"; diff --git a/cpan/version/t/06noop.t b/cpan/version/t/06noop.t index 8db4c75397..97c7e6546e 100644 --- a/cpan/version/t/06noop.t +++ b/cpan/version/t/06noop.t @@ -7,7 +7,7 @@ use Test::More qw/no_plan/; BEGIN { - use_ok('version', 0.9906); + use_ok('version', 0.9907); } my $v1 = version->new('1.2'); diff --git a/cpan/version/t/07locale.t b/cpan/version/t/07locale.t index 3503b6ff80..de6588c072 100644 --- a/cpan/version/t/07locale.t +++ b/cpan/version/t/07locale.t @@ -11,7 +11,7 @@ use Test::More tests => 7; use Config; BEGIN { - use_ok('version', 0.9906); + use_ok('version', 0.9907); } SKIP: { diff --git a/cpan/version/t/08_corelist.t b/cpan/version/t/08_corelist.t index 8cd2e1427b..48c61c3e6c 100644 --- a/cpan/version/t/08_corelist.t +++ b/cpan/version/t/08_corelist.t @@ -5,7 +5,7 @@ ######################### use Test::More tests => 3; -use_ok("version", 0.9906); +use_ok("version", 0.9907); # do strict lax tests in a sub to isolate a package to test importing SKIP: { diff --git a/cpan/version/t/09_list_util.t b/cpan/version/t/09_list_util.t index 6348f9d406..110c1a035d 100644 --- a/cpan/version/t/09_list_util.t +++ b/cpan/version/t/09_list_util.t @@ -4,7 +4,7 @@ ######################### use strict; -use_ok("version", 0.9906); +use_ok("version", 0.9907); use Test::More; BEGIN { diff --git a/vutil.c b/vutil.c index 6cbfc72a22..7979c49c15 100644 --- a/vutil.c +++ b/vutil.c @@ -2,6 +2,7 @@ editing it in the perl core. */ #ifndef PERL_CORE +# define PERL_NO_GET_CONTEXT # include "EXTERN.h" # include "perl.h" # include "XSUB.h" @@ -283,8 +284,7 @@ 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); } } @@ -396,7 +396,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } } 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: @@ -432,7 +432,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) (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; } @@ -462,7 +462,7 @@ 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(); @@ -483,24 +483,24 @@ Perl_new_version(pTHX_ SV *ver) 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)); } @@ -512,12 +512,11 @@ Perl_new_version(pTHX_ SV *ver) 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 @@ -556,7 +555,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) PERL_ARGS_ASSERT_UPG_VERSION; - if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) + if ( SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) ) { STRLEN len; @@ -578,11 +577,13 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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 @@ -593,16 +594,19 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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) ) { version = savesvpv(ver); + SAVEFREEPV(version); } else if ( SvPOK(ver) )/* must be a string or something like a string */ { 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 */ @@ -619,6 +623,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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' */ @@ -630,7 +635,6 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) /* is definitely a v-string */ if ( saw_decimal >= 2 ) { - Safefree(version); version = nver; } break; @@ -651,7 +655,6 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Version string '%s' contains invalid data; " "ignoring: '%s'", version, s); - Safefree(version); return ver; } @@ -689,6 +692,7 @@ Perl_vverify(pTHX_ SV *vs) #endif { SV *sv; + SV **svp; PERL_ARGS_ASSERT_VVERIFY; @@ -697,8 +701,8 @@ Perl_vverify(pTHX_ SV *vs) /* 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 @@ -745,10 +749,13 @@ 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 */ @@ -762,11 +769,15 @@ Perl_vnumify(pTHX_ SV *vs) 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); @@ -779,7 +790,8 @@ Perl_vnumify(pTHX_ SV *vs) 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); @@ -835,17 +847,22 @@ 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 @@ -879,6 +896,7 @@ Perl_vstringify2(pTHX_ SV *vs) Perl_vstringify(pTHX_ SV *vs) #endif { + SV ** svp; PERL_ARGS_ASSERT_VSTRINGIFY; /* extract the HV from the object */ @@ -886,9 +904,10 @@ Perl_vstringify(pTHX_ SV *vs) 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 @@ -951,8 +970,11 @@ 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 ) @@ -979,7 +1001,8 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) { 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++; } @@ -988,7 +1011,8 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) { 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++; } diff --git a/vutil.h b/vutil.h index f86631d654..aaf2284e89 100644 --- a/vutil.h +++ b/vutil.h @@ -83,7 +83,49 @@ Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) -#define ISA_CLASS_OBJ(v,c) (sv_isobject(v) && sv_derived_from(v,c)) +#if PERL_VERSION_LT(5,15,4) +# define ISA_VERSION_OBJ(v) (sv_isobject(v) && sv_derived_from(v,"version")) +#else +# define ISA_VERSION_OBJ(v) (sv_isobject(v) && sv_derived_from_pvn(v,"version",7,0)) +#endif + + +#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE +#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) + +/* prototype to pass -Wmissing-prototypes */ +STATIC void +S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); + +STATIC void +S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) +{ + const GV *const gv = CvGV(cv); + + PERL_ARGS_ASSERT_CROAK_XS_USAGE; + + if (gv) { + const char *const gvname = GvNAME(gv); + const HV *const stash = GvSTASH(gv); + const char *const hvname = stash ? HvNAME(stash) : NULL; + + if (hvname) + Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params); + else + Perl_croak_nocontext("Usage: %s(%s)", gvname, params); + } else { + /* Pants. I don't think that it should be possible to get here. */ + Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + } +} + +#ifdef PERL_IMPLICIT_CONTEXT +#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) +#else +#define croak_xs_usage S_croak_xs_usage +#endif + +#endif #if PERL_VERSION_GE(5,9,0) && !defined(PERL_CORE) @@ -109,8 +151,10 @@ const char * Perl_prescan_version2(pTHX_ const char *s, bool strict, const char* # define VNORMAL(a) Perl_vnormal2(aTHX_ a) # define VCMP(a,b) Perl_vcmp2(aTHX_ a,b) # define PRESCAN_VERSION(a,b,c,d,e,f,g) Perl_prescan_version2(aTHX_ a,b,c,d,e,f,g) +# undef is_LAX_VERSION # define is_LAX_VERSION(a,b) \ (a != Perl_prescan_version2(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL)) +# undef is_STRICT_VERSION # define is_STRICT_VERSION(a,b) \ (a != Perl_prescan_version2(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL)) @@ -177,3 +221,21 @@ const char * Perl_prescan_version(pTHX_ const char *s, bool strict, const char** # define PERL_ARGS_ASSERT_CK_WARNER \ assert(pat) #endif + + +#if PERL_VERSION_LT(5,19,0) +# undef STORE_NUMERIC_LOCAL_SET_STANDARD +# undef RESTORE_NUMERIC_LOCAL +# ifdef USE_LOCALE +# define STORE_NUMERIC_LOCAL_SET_STANDARD()\ + char *loc = savepv(setlocale(LC_NUMERIC, NULL)); \ + SAVEFREEPV(loc); \ + setlocale(LC_NUMERIC, "C"); + +# define RESTORE_NUMERIC_LOCAL()\ + setlocale(LC_NUMERIC, loc); +# else +# define STORE_NUMERIC_LOCAL_SET_STANDARD() +# define RESTORE_NUMERIC_LOCAL() +# endif +#endif diff --git a/vxs.inc b/vxs.inc index 2e4f409390..0a02056561 100644 --- a/vxs.inc +++ b/vxs.inc @@ -4,49 +4,53 @@ #ifdef PERL_CORE # define VXS_CLASS "version" # define VXSp(name) XS_##name +/* VXSXSDP = XSUB Details Proto */ +# define VXSXSDP(x) x #else # define VXS_CLASS "version::vxs" # define VXSp(name) VXS_##name +/* proto member is unused in version, it is used in CORE by non version xsubs */ +# define VXSXSDP(x) #endif #define VXS(name) XS(VXSp(name)) #ifdef VXS_XSUB_DETAILS # ifdef PERL_CORE - {"UNIVERSAL::VERSION", VXSp(universal_version), NULL}, + {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)}, # endif - {VXS_CLASS "::_VERSION", VXSp(universal_version), NULL}, - {VXS_CLASS "::()", VXSp(version_noop), NULL}, - {VXS_CLASS "::new", VXSp(version_new), NULL}, - {VXS_CLASS "::parse", VXSp(version_new), NULL}, - {VXS_CLASS "::(\"\"", VXSp(version_stringify), NULL}, - {VXS_CLASS "::stringify", VXSp(version_stringify), NULL}, - {VXS_CLASS "::(0+", VXSp(version_numify), NULL}, - {VXS_CLASS "::numify", VXSp(version_numify), NULL}, - {VXS_CLASS "::normal", VXSp(version_normal), NULL}, - {VXS_CLASS "::(cmp", VXSp(version_vcmp), NULL}, - {VXS_CLASS "::(<=>", VXSp(version_vcmp), NULL}, + {VXS_CLASS "::_VERSION", VXSp(universal_version), VXSXSDP(NULL)}, + {VXS_CLASS "::()", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::new", VXSp(version_new), VXSXSDP(NULL)}, + {VXS_CLASS "::parse", VXSp(version_new), VXSXSDP(NULL)}, + {VXS_CLASS "::(\"\"", VXSp(version_stringify), VXSXSDP(NULL)}, + {VXS_CLASS "::stringify", VXSp(version_stringify), VXSXSDP(NULL)}, + {VXS_CLASS "::(0+", VXSp(version_numify), VXSXSDP(NULL)}, + {VXS_CLASS "::numify", VXSp(version_numify), VXSXSDP(NULL)}, + {VXS_CLASS "::normal", VXSp(version_normal), VXSXSDP(NULL)}, + {VXS_CLASS "::(cmp", VXSp(version_vcmp), VXSXSDP(NULL)}, + {VXS_CLASS "::(<=>", VXSp(version_vcmp), VXSXSDP(NULL)}, # ifdef PERL_CORE - {VXS_CLASS "::vcmp", XS_version_vcmp, NULL}, + {VXS_CLASS "::vcmp", XS_version_vcmp, VXSXSDP(NULL)}, # else - {VXS_CLASS "::VCMP", VXS_version_vcmp, NULL}, + {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(NULL)}, # endif - {VXS_CLASS "::(bool", VXSp(version_boolean), NULL}, - {VXS_CLASS "::boolean", VXSp(version_boolean), NULL}, - {VXS_CLASS "::(+", VXSp(version_noop), NULL}, - {VXS_CLASS "::(-", VXSp(version_noop), NULL}, - {VXS_CLASS "::(*", VXSp(version_noop), NULL}, - {VXS_CLASS "::(/", VXSp(version_noop), NULL}, - {VXS_CLASS "::(+=", VXSp(version_noop), NULL}, - {VXS_CLASS "::(-=", VXSp(version_noop), NULL}, - {VXS_CLASS "::(*=", VXSp(version_noop), NULL}, - {VXS_CLASS "::(/=", VXSp(version_noop), NULL}, - {VXS_CLASS "::(abs", VXSp(version_noop), NULL}, - {VXS_CLASS "::(nomethod", VXSp(version_noop), NULL}, - {VXS_CLASS "::noop", VXSp(version_noop), NULL}, - {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), NULL}, - {VXS_CLASS "::qv", VXSp(version_qv), NULL}, - {VXS_CLASS "::declare", VXSp(version_qv), NULL}, - {VXS_CLASS "::is_qv", VXSp(version_is_qv), NULL}, + {VXS_CLASS "::(bool", VXSp(version_boolean), VXSXSDP(NULL)}, + {VXS_CLASS "::boolean", VXSp(version_boolean), VXSXSDP(NULL)}, + {VXS_CLASS "::(+", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(-", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(*", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(/", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(+=", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(-=", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(*=", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(/=", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(abs", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::(nomethod", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::noop", VXSp(version_noop), VXSXSDP(NULL)}, + {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), VXSXSDP(NULL)}, + {VXS_CLASS "::qv", VXSp(version_qv), VXSXSDP(NULL)}, + {VXS_CLASS "::declare", VXSp(version_qv), VXSXSDP(NULL)}, + {VXS_CLASS "::is_qv", VXSp(version_is_qv), VXSXSDP(NULL)}, #else #ifndef dVAR @@ -73,7 +77,6 @@ VXS(universal_version) HV *pkg; GV **gvp; GV *gv; - SV *ret; SV *sv; const char *undef; PERL_UNUSED_ARG(cv); @@ -97,12 +100,12 @@ VXS(universal_version) if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { sv = sv_mortalcopy(sv); - if ( ! ISA_CLASS_OBJ(sv, "version")) + if ( ! ISA_VERSION_OBJ(sv) ) UPG_VERSION(sv, FALSE); undef = NULL; } else { - sv = ret = &PL_sv_undef; + sv = &PL_sv_undef; undef = "(undef)"; } @@ -135,7 +138,7 @@ VXS(universal_version) } } - if ( ! ISA_CLASS_OBJ(req, "version")) { + if ( ! ISA_VERSION_OBJ(req) ) { /* req may very well be R/O, so create a new object */ req = sv_2mortal( NEW_VERSION(req) ); } @@ -155,10 +158,9 @@ VXS(universal_version) SVfARG(sv_2mortal(sv))); } } - ST(0) = ret; /* if the package's $VERSION is not undef, it is upgraded to be a version object */ - if (ISA_CLASS_OBJ(sv, "version")) { + if (ISA_VERSION_OBJ(sv)) { ST(0) = sv_2mortal(VSTRINGIFY(sv)); } else { ST(0) = sv; @@ -176,6 +178,7 @@ VXS(version_new) const char * classname = ""; STRLEN len; U32 flags = 0; + SV * svarg0 = NULL; PERL_UNUSED_VAR(cv); SP -= items; @@ -192,16 +195,19 @@ VXS(version_new) sv_setpvs(vs,"undef"); } else if (items == 3 ) { + SV * svarg2; vs = sv_newmortal(); + svarg2 = ST(2); #if PERL_VERSION == 5 - sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2))); + sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2)); #else - Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); + Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2)); #endif } - if ( sv_isobject(ST(0)) ) { + svarg0 = ST(0); + if ( sv_isobject(svarg0) ) { /* get the class if called as an object method */ - const HV * stash = SvSTASH(SvRV(ST(0))); + const HV * stash = SvSTASH(SvRV(svarg0)); classname = HvNAME_get(stash); len = HvNAMELEN_get(stash); #ifdef HvNAMEUTF8 @@ -209,8 +215,8 @@ VXS(version_new) #endif } else { - classname = SvPV(ST(0), len); - flags = SvUTF8(ST(0)); + classname = SvPV(svarg0, len); + flags = SvUTF8(svarg0); } rv = NEW_VERSION(vs); @@ -229,8 +235,9 @@ VXS(version_new) #define VTYPECHECK(var, val, varname) \ STMT_START { \ - if (ISA_CLASS_OBJ(val, "version")) { \ - (var) = SvRV(val); \ + SV * sv_vtc = val; \ + if (ISA_VERSION_OBJ(sv_vtc)) { \ + (var) = SvRV(sv_vtc); \ } \ else \ Perl_croak(aTHX_ varname " is not of type version"); \ @@ -304,10 +311,9 @@ VXS(version_vcmp) SV * robj = ST(1); const IV swap = (IV)SvIV(ST(2)); - if ( !ISA_CLASS_OBJ(robj, "version") ) + if ( !ISA_VERSION_OBJ(robj) ) { - robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)); - sv_2mortal(robj); + robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP))); } rvs = SvRV(robj); @@ -357,32 +363,40 @@ VXS(version_noop) dXSARGS; if (items < 1) croak_xs_usage(cv, "lobj, ..."); - if (ISA_CLASS_OBJ(ST(0), "version")) + if (ISA_VERSION_OBJ(ST(0))) Perl_croak(aTHX_ "operation not supported with version object"); else Perl_croak(aTHX_ "lobj is not of type version"); XSRETURN_EMPTY; } -VXS(version_is_alpha) +static +void +S_version_check_key(pTHX_ CV * cv, const char * key, int keylen) { dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "lobj"); - SP -= items; { - SV *lobj; - VTYPECHECK(lobj, ST(0), "lobj"); - if ( hv_exists(MUTABLE_HV(lobj), "alpha", 5 ) ) - XSRETURN_YES; + SV *lobj = POPs; + SV *ret; + VTYPECHECK(lobj, lobj, "lobj"); + if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) ) + ret = &PL_sv_yes; else - XSRETURN_NO; + ret = &PL_sv_no; + PUSHs(ret); PUTBACK; return; } } +VXS(version_is_alpha) +{ + S_version_check_key(aTHX_ cv, "alpha", 5); +} + VXS(version_qv) { dVAR; @@ -391,20 +405,22 @@ VXS(version_qv) SP -= items; { SV * ver = ST(0); + SV * sv0 = ver; SV * rv; STRLEN len = 0; const char * classname = ""; U32 flags = 0; if ( items == 2 ) { - SvGETMAGIC(ST(1)); - if (SvOK(ST(1))) { - ver = ST(1); + SV * sv1 = ST(1); + SvGETMAGIC(sv1); + if (SvOK(sv1)) { + ver = sv1; } else { Perl_croak(aTHX_ "Invalid version format (version required)"); } - if ( sv_isobject(ST(0)) ) { /* class called as an object method */ - const HV * stash = SvSTASH(SvRV(ST(0))); + if ( sv_isobject(sv0) ) { /* class called as an object method */ + const HV * stash = SvSTASH(SvRV(sv0)); classname = HvNAME_get(stash); len = HvNAMELEN_get(stash); #ifdef HvNAMEUTF8 @@ -412,8 +428,8 @@ VXS(version_qv) #endif } else { - classname = SvPV(ST(0), len); - flags = SvUTF8(ST(0)); + classname = SvPV(sv0, len); + flags = SvUTF8(sv0); } } if ( !SvVOK(ver) ) { /* not already a v-string */ @@ -437,23 +453,10 @@ VXS(version_qv) return; } + VXS(version_is_qv) { - dVAR; - dXSARGS; - if (items != 1) - croak_xs_usage(cv, "lobj"); - SP -= items; - { - SV *lobj; - VTYPECHECK(lobj, ST(0), "lobj"); - if ( hv_exists(MUTABLE_HV(lobj), "qv", 2 ) ) - XSRETURN_YES; - else - XSRETURN_NO; - PUTBACK; - return; - } + S_version_check_key(aTHX_ cv, "qv", 2); } #endif -- cgit v1.2.1