@@ -1,8 +1,555 @@
+2014-02-03 John Peacock <john.peacock@havurah-software.org>
+
+ * .hgtags:
+ Tagging version '0.9908' using shipit.
+ [2bb065d82876] [tip]
+
+2014-02-01 John Peacock <john.peacock@havurah-software.org>
+
+ * README, lib/version.pm, lib/version/regex.pm, t/00impl-pp.t,
+ t/01base.t, t/02derived.t, t/03require.t, t/05sigdie.t, t/06noop.t,
+ t/07locale.t, t/08_corelist.t, t/09_list_util.t, vperl/vpp.pm,
+ vutil/lib/version/vxs.pm:
+ Ready for release to CPAN
+ [8143deb9480e] [0.9908]
+
+2014-02-02 John Peacock <john.peacock@havurah-software.org>
+
+ * MANIFEST, Makefile.PL, vutil/Makefile.PL:
+ Slight tweaks to Makefile.PL to make it smarter and add standalone
+ Makefile.PL for vxs code
+ [3cd691eea31e]
+
+2014-02-01 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.c:
+ We should mortalize in the caller, not the callee
+ [ba2e8bb9de43]
+
+ * vutil/vutil.c:
+ Prevent leaking if upg_version dies before returning
+ [b56054bcaf22]
+
+ * vutil/vutil.c:
+ Put all of the private check flags at the end
+ [de677ab32388]
+
+ * vutil/vutil.c:
+ Reorder tests to be IV, NV, PV in that order
+ [5b56c32404b2]
+
+ * vutil/vutil.c:
+ And do not forget about the integer case
+ [645c700be118]
+
+ * vutil/vutil.c:
+ Extra paranoia; prefer SvPOK before taking SvNOKp.
+ [501517a03119]
+
+ * vutil/vutil.c:
+ Deal with certain tiedscalars (e.g. created by Readonly::XS).
+ Resolves https://rt.cpan.org/Ticket/Display.html?id=92540
+ [efb44fbc6bd8]
+
+ * vperl/vpp.pm:
+ Whitespace consistency and cuddled braces on subs
+ [5e76102adf1a]
+
+ * vperl/vpp.pm:
+ Simplify parsing of parameters in new() like the XS code does
+ [3f260ed4603c]
+
+2014-01-28 bulk88 <bulk88@hotmail.com>
+
+ * vutil/vxs.inc:
+ VXS_RETURN_M_SV optimization
+ [24df4a74aa08]
+
+ * vutil/vxs.inc:
+ fix theoretical uninit Perl stack reads in XS version::new see Perl
+ #115660 and CPAN #92438
+ [3c329a938ad5]
+
+2014-01-19 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.c:
+ Prevent bug in threads::shared from causing problems Effective only
+ for Perl < 5.19.8.
+ [aae0051131e7]
+
+2014-01-17 John Peacock <john.peacock@havurah-software.org>
+
+ * vperl/vpp.pm:
+ Move the locale stuff after the _un_vstring, so we don't
+ accidentally strip the V-magic
+ [bdb0f5310262]
+
+2014-01-15 John Peacock <john.peacock@havurah-software.org>
+
+ * .hgtags:
+ Tagging version '0.9907' using shipit.
+ [59f891910a94]
+
+2014-01-14 John Peacock <john.peacock@havurah-software.org>
+
+ * Makefile.PL, README, lib/version.pm, vperl/vpp.pm:
+ Stop supporting Perl releases prior to v5.6.2. Tweak the code to
+ prevent locale from causing troubles where it cannot be used, e.g.
+ Android.
+ [0eb90073ce68] [0.9907]
+
+ * vutil/vutil.c:
+ That is lval not the length of the key
+ [00fff6f82ffd]
+
+2014-01-13 John Peacock <john.peacock@havurah-software.org>
+
+ * README:
+ Final tweaks before releasing
+ [7b1b98341550]
+
+ * Makefile.PL, README, t/07locale.t, vperl/vpp.pm:
+ Better way to handle locale under Android
+ [5ba9c78a80f2]
+
+2014-01-13 Piotr Roszatycki <piotr.roszatycki@gmail.com>
+
+ * vutil/vutil.h:
+ Check USE_LOCALE
+ [9a4981da2550]
+
+2014-01-13 John Peacock <john.peacock@havurah-software.org>
+
+ * README:
+ Correct spelling
+ [bb0b009054a5]
+
+2014-01-12 John Peacock <john.peacock@havurah-software.org>
+
+ * Makefile.PL, vperl/vpp.pm:
+ Isolate the locale testing to make it easier to deal with on
+ Android. On Android, strip out 'use locale' so that it doesn't fall
+ over.
+ [bf28d1047cf5]
+
+ * README, lib/version.pm, lib/version/regex.pm, t/00impl-pp.t,
+ t/01base.t, t/02derived.t, t/03require.t, t/05sigdie.t, t/06noop.t,
+ t/07locale.t, t/08_corelist.t, t/09_list_util.t, vperl/vpp.pm,
+ vutil/lib/version/vxs.pm:
+ $VERSION++ for CPAN release.
+ [bf8d867fdd67]
+
+2014-01-11 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.h:
+ The new macros, and indeed the previous macros, do not work on Perl
+ prior to 5.19.0 because the bug is actually how in Perl itself
+ handles the locale bits. So we just go back to effectively always
+ saving the locale. Resolves:
+
+ https://rt.cpan.org/Ticket/Display.html?id=91987
+ [9dc839b97fbb]
+
+2014-01-06 bulk88 <bulk88@hotmail.com>
+
+ * vutil/vutil.c, vutil/vutil.h, vutil/vxs.inc, vutil/vxs.xs:
+ various XS optimizations and a leak fix vutil.h
+ -restore 5.10 and 5.12 compatiblity, S_croak_xs_usage came from
+ Win32::API
+
+ vutil.c
+ -add PERL_NO_GET_CONTEXT to both translation units
+ -remove all hv_exists/hv_fetchs patterns and replace with 1 hv key
+ getter
+ -remove all SvIV(*av_fetch patterns, av_fetch is called multiple
+ times in the SvIV macro
+ -in new_version, directly use version * directly, savepvn isn't
+ needed and doesn't convert character encoding either
+ -in upg_version, recently this function was converted to use
+ SAVEFREEPV this savesvpv was missed
+
+ vxs.inc
+ -make xsub details table smaller in the binary by getting rid of the
+ NULL entries, version doesn't use prototypes, but in CORE other
+ xsubs use them in this table
+ -in VXS(version_new) don't read PL_stack_base more than necessary
+ -in VTYPECHECK, make this macro eval the SV* only once. ST(123) was
+ multi evaling/multiple recalcs of it, also this now makes POPs safe
+ to pass.
+ -in VXS(version_vcmp) take advantage of sv_2mortal's return val for
+ smaller machine code
+ -because of XSUB details table, ALIAS:/XSANY can't be used, factor
+ out VXS(version_is_alpha) and VXS(version_is_qv), and make the XS
+ stubs tailcall friendly on regcall ABIs
+ -in S_version_check_key use SP semantics instead of ax, less machine
+ code
+ -in VXS(version_qv) don't read PL_stack_base more than necessary,
+ this fnc could be further cleaned up, since it has obvious signs of
+ xsubpp and hand written portions
+ [f9d01679492f]
+
+2014-01-05 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.c, vutil/vutil.h, vutil/vxs.inc:
+ This was more subtle than I had initially understood
+ [649e700fadae]
+
+ * vutil/vutil.h:
+ Somewhat faster because we avoid a strlen() call
+ [11fb73b0be3f]
+
+ * MANIFEST, Makefile.PL, vutil/vxs.xs:
+ Apparently we do still need this, at least for Windows. grrr
+ [b4d4e0057b40]
+
+2014-01-04 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.c:
+ Only need to compare the remaining string
+ [8f1352c79510]
+
+ * vutil/vutil.c:
+ Use AvFILLp since we know av is not magical
+ [a5367b183ff0]
+
+ * vutil/vutil.c:
+ Arrange for all saved strings to be cleaned up on scope exit
+ [7a76ab3bbf84]
+
+ * vutil/vutil.c:
+ Use macro instead of function call for efficiency
+ [d03bfc7f7f0f]
+
+ * MANIFEST, Makefile.PL, vutil/vxs.xs:
+ Do not need vxs.xs any longer
+ [c2cc74f7ebf4]
+
+ * vutil/vxs.inc:
+ Remove unnecessary variable. Resolves:
+ https://rt.cpan.org/Ticket/Display.html?id=91867
+ [190410bc3966]
+
+ * vutil/vutil.c:
+ Use equivalent macro from Perl
+ [ffc872209ccb]
+
+ * .hgtags:
+ Tagging version '0.9906' using shipit.
+ [f3985248813a]
+
+ * README:
+ Update README for new CPAN release.
+ [9f49d95d787c] [0.9906]
+
+ * lib/version.pm, lib/version/Internals.pod, lib/version/regex.pm, t
+ /00impl-pp.t, t/01base.t, t/02derived.t, t/03require.t,
+ t/04strict_lax.t, t/05sigdie.t, t/06noop.t, t/07locale.t,
+ t/08_corelist.t, t/09_list_util.t, vperl/vpp.pm,
+ vutil/lib/version/vxs.pm:
+ Restore $version::LAX functionality, resolves:
+
+ https://rt.cpan.org/Ticket/Display.html?id=91858
+ [3129d0a133d9]
+
+2014-01-04 Karl Williamson <public@khwilliamson.com>
+
+ * vutil/vxs.inc:
+ vxs.inc: Move code to after declarations This macro, added in
+ e1c774b6, is actual code, and needs to be after the declarations, so
+ that C89 compilers compile it.
+ [d2ac7d3ab38f]
+
+2014-01-04 John Peacock <john.peacock@havurah-software.org>
+
+ * .hgtags:
+ Tagging version '0.9905' using shipit.
+ [5b7173e3cf28]
+
+ * README:
+ Ready to release to CPAN
+ [143beb1ecc7c] [0.9905]
+
+ * Makefile.PL, lib/version.pm, t/09_list_util.t, vperl/vpp.pm:
+ Finally resolve all test failures going back to 5.005_04
+ [e291744a1699]
+
+ * lib/version/typemap:
+ Merge from sprout branch now that it is in the core
+ [414c7e7bdab3]
+
+ * Ready to merge to default
+ [0e5b9977f472] <sprout>
+
+2013-12-29 John Peacock <john.peacock@havurah-software.org>
+
+ * t/coretests.pm, vperl/vpp.pm, vutil/vutil.c:
+ Protect against arrayref/hashref being used to initialize.
+ [cae5dc47e323] <sprout>
+
+ * vutil/vxs.inc:
+ Always export version::_VERSION method
+ [3ef36df5fa82] <sprout>
+
+2013-12-29 Father Chrysostomos <sprout@cpan.org>
+
+ * vutil/vxs.inc:
+ Use VXS_ prefix for XSUB bodies in CPAN version The names of the
+ functions in core and in the CPAN version will con- flict otherwise.
+
+ Since perl versions before 5.16.0 did not have XS_INTERNAL (which
+ could solve this problem another way, making the functions static),
+ it’s easier just to use different names.
+ [e5ff1195df80] <sprout>
+
+2013-12-29 John Peacock <john.peacock@havurah-software.org>
+
+ * MANIFEST, Makefile.PL, vutil/vxs.in, vutil/vxs.inc:
+ Revert these changes prior to importing patch from Sprout
+ [aa7f38340804] <sprout>
+
+ * lib/version.pm, vutil/lib/version/vxs.pm:
+ Mark block to be deleted when adding to Perl core. Simplify usage of
+ version::regex.
+ [45e5f442c363] <sprout>
+
+2013-12-26 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.c:
+ Improve upg_version for abusively large NV case.
+
+ From: Daniel Dragan <bulk88@hotmail.com> Date: Thu, 26 Dec 2013
+ 01:09:39 -0500 Subject: [PATCH] remove redundant SV operations from
+ upg_version
+
+ sv is empty because it is new, setpvf will do useless sv_vsetpvf(sv,
+ "") before calling sv_vcatpvfn_flags, just call sv_catpvf.
+ sv_vcatpvfn_flags does a sv_pvn_force_flags, so sv will always be
+ POK afterwards, so just access members directly and remove SV
+ conversion check and branch. upg_version should be a tiny bit faster
+ in case abusively long versions are parsed. This commit improves the
+ commit 78e230aef1 for perl #112478.
+ [255cc73939b7] <sprout>
+
+2013-12-25 John Peacock <john.peacock@havurah-software.org>
+
+ * Makefile.PL:
+ Prevent shadowed version.pm. Resolves
+ https://rt.cpan.org/Ticket/Display.html?id=88909
+ [234d5fe16460] <sprout>
+
+ * MANIFEST, t/09_list_util.t, vutil/vutil.c, vutil/vxs.in:
+ Don't steal SV's when you can help it. Resolves
+ https://rt.cpan.org/Ticket/Display.html?id=91323
+ [87b481c20881] <sprout>
+
+ * t/coretests.pm, vutil/vutil.c:
+ Need to handle [unsigned] integers differently.
+ [1f178af738e5] <sprout>
+
+2013-12-22 Karl Williamson <public@khwilliamson.com>
+
+ * t/07locale.t:
+ t/07locale.t: 'use locale' needs to be moved A test that is supposed
+ to be outside the scope of 'use locale' is instead within the scope.
+ [e9c9b887a74b] <sprout>
+
+ * t/07locale.t:
+ t/07locale.t: Tests were likely skipped The logic was wrong in the
+ loop exit, so that on the many machines that don't have an Afghan
+ locale, most tests in the file are skipped. The problem is that it
+ wasn't testing if changing to the trial locale actually worked.
+ [7b9d5921f6dd] <sprout>
+
+2013-12-07 John Peacock <john.peacock@havurah-software.org>
+
+ * t/coretests.pm, vperl/vpp.pm:
+ Do not hardcode 'version' when $CLASS is correct
+ [b1f2e197e70e] <sprout>
+
+2013-11-30 John Peacock <john.peacock@havurah-software.org>
+
+ * vperl/vpp.pm:
+ Go back to the old style since we need to still support older Perls
+ [8c3dd9b09c8c] <sprout>
+
+ * lib/version.pm, lib/version/regex.pm, vperl/vpp.pm,
+ vutil/lib/version/vxs.pm:
+ Be consistent about what minimum Perl version we support
+ [3a1ba8a49521] <sprout>
+
+ * MANIFEST, Makefile.PL, README, lib/version.pm, lib/version/typemap,
+ t/00impl-xs.t, vutil/lib/version/vxs.pm, vutil/vxs.in:
+ Complete exercise to make version:vpp independent. Deprecate XS code
+ in all Perl releases prior to v5.10
+ [e8095080969c] <sprout>
+
+2013-11-19 John Peacock <john.peacock@havurah-software.org>
+
+ * lib/version.pm, lib/version/regex.pm, vperl/vpp.pm,
+ vutil/lib/version/vxs.pm:
+ Finally have all tests passing
+ [6e0377fec777] <sprout>
+
+2013-11-17 John Peacock <john.peacock@havurah-software.org>
+
+ * MANIFEST, Makefile.PL, lib/version.pm, lib/version/regex.pm,
+ t/02derived.t, vperl/vpp.pm, vutil/lib/version/vxs.pm:
+ Move regexes to independent class and make both implementation class
+ completely standalone
+ [192ce2309a99] <sprout>
+
+2013-11-12 John Peacock <john.peacock@havurah-software.org>
+
+ * t/coretests.pm:
+ Do not assume what the class is here
+ [2caf7c7a3b12] <sprout>
+
+2013-11-03 Father Chrysostomos <sprout@cpan.org>
+
+ * vutil/vxs.in:
+ vxs.inc: Fix thinko This was causing test failures after rebasing
+ against blead.
+ [886acc1dc1c9] <sprout>
+
+2013-11-03 John Peacock <john.peacock@havurah-software.org>
+
+ * MANIFEST, Makefile.PL, vutil/vxs.in, vutil/vxs.inc:
+ Rename vxs.inc to vxs.in so we can edit on the fly out-of-core
+ [dab16fd6384e] <sprout>
+
+2013-10-23 John Peacock <john.peacock@havurah-software.org>
+
+ * MANIFEST:
+ Add new implementation class tests to MANIFEST.
+ [88bf30fb7335] <sprout>
+
+ * Makefile.PL:
+ Need to rename XS_UNIVERSAL_VERSION as well.
+ [ec99e6586265] <sprout>
+
+2013-10-22 John Peacock <john.peacock@havurah-software.org>
+
+ * vperl/vpp.pm:
+ Merge from default
+ [e61323b2f598] <sprout>
+
+ * Makefile.PL, t/00impl-pp.t, t/00impl-xs.t, vperl/vpp.pm:
+ Dupe the import() routine so that version:vpp is standalone
+ [8464fd2353e7] <sprout>
+
+ * Makefile.PL:
+ Need to rename the XS functions outside of the core
+ [2b38b93a93d9] <sprout>
+
+2013-10-18 John Peacock <john.peacock@havurah-software.org>
+
+ * lib/version.pm, t/01base.t, t/02derived.t, t/03require.t,
+ t/05sigdie.t, t/06noop.t, t/07locale.t, t/08_corelist.t,
+ vperl/vpp.pm, vutil/lib/version/vxs.pm:
+ Bump $VERSION. Make version::vpp a completely standalone class and
+ test it.
+ [68da07b3d1d1]
+
+2013-10-16 John Peacock <john.peacock@havurah-software.org>
+
+ * lib/version.pm, t/01base.t, t/02derived.t, t/03require.t,
+ t/05sigdie.t, t/06noop.t, t/07locale.t, t/08_corelist.t,
+ vperl/vpp.pm, vutil/lib/version/vxs.pm, vutil/vxs.xs:
+ Bump $VERSION everywhere. Make details[] static array
+ [0303b632df78] <sprout>
+
+2013-10-08 Father Chrysostomos <sprout@cpan.org>
+
+ * vutil/vxs.inc:
+ vxs.inc: qv: Backport perl 5.16's utf8 and null handling ppport.h
+ provides HvNAMELEN_get, but we have to use #ifdefs for HvNAMEUTF8.
+ [35248c2474c9] <sprout>
+
+ * t/coretests.pm:
+ Another test for #88495, this time with qv This bug was also caused
+ by perl commit ed1db70e122, the CPAN version being unaffected.
+ [4fa3d433a173] <sprout>
+
+ * vutil/vxs.inc:
+ vxs.inc: new: Backport perl 5.16's utf8 and null handling ppport.h
+ provides HvNAMELEN_get, but we have to use #ifdefs for HvNAMEUTF8.
+ [24a3f9dc48f1] <sprout>
+
+ * vutil/vxs.inc:
+ vxs.inc: new: Don't hard-code class name
+ [e761e21c1db2] <sprout>
+
+ * t/coretests.pm:
+ Test rt.cpan.org #88495 This string comparison bug has only ever
+ existed in the perl core. It was ed1db70e1224 in 5.16 that
+ introduced it
+ [8c74c593ab60] <sprout>
+
+ * vutil/vxs.inc:
+ vxs.inc: new: Avoid Perl_sv_setpvf_nocontext sv_setpvf expands to
+ Perl_sv_setpvf_nocontext under threaded builds starting from 5.6.
+ Perl_sv_setpvf_nocontext is slow because it has to call a special
+ OS-provided function to fetch the interpreter object associated with
+ the current thread. Just passing the interpreter through is faster.
+ This is what the blead version of this routine already does.
+
+ perl 5.005 does not have long Perl_* names, so we have to do it the
+ old way for that version.
+ [5ffa46f7c2d6] <sprout>
+
+ * vutil/vxs.inc:
+ vxs.inc: new: check arglist first, don't read beyond Check the
+ number of arguments before reading any. Using ST(1) when items == 1
+ *shouldn’t* cause any problems if the value returned is never used,
+ but it could theoretically read into unallocated memory.
+
+ Also, don’t bother with get-magic if we are going to croak anyway
+ (>3 args).
+ [77e4604d43f1] <sprout>
+
+ * vutil/vxs.inc:
+ vxs.inc: Remove use of Null(...) This is not defined under
+ PERL_CORE.
+ [ccb2049fc81c] <sprout>
+
+ * vutil/vxs.inc:
+ vxs.inc:VERSION: backport utf8 and null handling from blead Since
+ older perls than 5.16 didn’t have HEKf and 5.8 not even HvNAME_HEK,
+ we need an #ifdef maze.
+ [d1b03ff71c8d] <sprout>
+
+ * vutil/vxs.inc:
+ RT #88572: Better usage msg for UNIVERSAL::VERSION() I.e., mention
+ UNIVERSAL::VERSION rather than version::vxs::_VERSION.
+ [89e6712c44cf] <sprout>
+
+ * MANIFEST, Makefile.PL, vutil/vxs.inc, vutil/vxs.xs:
+ Extract XS routines into a separate file This way the same vxs.inc
+ can be included by the perl’s universal.c and by our vxs.xs.
+ [e42f0b6eee81] <sprout>
+
+ * vutil/vutil.c, vutil/vutil.h:
+ Make vutil.* meet the Perl core's needs This brings version.pm and
+ perl’s copies of vutil.* into synch.
+ [de6daa4fa5f0] <sprout>
+
+2013-09-23 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.c:
+ Handle integer-only versions that overflow either UV or IV
+ [57698e44e5ee]
+
+2013-09-05 John Peacock <john.peacock@havurah-software.org>
+
+ * vutil/vutil.c:
+ Use savepvn() for efficiency
+ [96ed7a4be81e]
+
2013-09-02 John Peacock <john.peacock@havurah-software.org>
* .hgtags:
Tagging version '0.9904' using shipit.
- [4fab8f3e7a2c] [tip]
+ [4fab8f3e7a2c]
* t/08_corelist.t:
Almost forgot to add this
@@ -1,13 +1,14 @@
Changes
lib/version.pm
lib/version.pod
-lib/version/typemap
+lib/version/regex.pm
lib/version/Internals.pod
Makefile.PL
MANIFEST
MANIFEST.SKIP
META.yml
README
+t/00impl-pp.t
t/01base.t
t/02derived.t
t/03require.t
@@ -16,12 +17,15 @@ t/05sigdie.t
t/06noop.t
t/07locale.t
t/08_corelist.t
+t/09_list_util.t
t/coretests.pm
t/survey_locales
vperl/vpp.pm
+vutil/Makefile.PL
vutil/lib/version/vxs.pm
vutil/ppport.h
vutil/vutil.c
vutil/vutil.h
+vutil/vxs.inc
vutil/vxs.xs
META.json Module JSON meta-data (added by MakeMaker)
@@ -4,7 +4,7 @@
"John Peacock <jpeacock@cpan.org>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.112621",
+ "generated_by" : "ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.120351",
"license" : [
"perl_5"
],
@@ -22,22 +22,24 @@
"prereqs" : {
"build" : {
"requires" : {
- "ExtUtils::MakeMaker" : 0
+ "ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
- "ExtUtils::MakeMaker" : 0
+ "ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
+ "ExtUtils::MakeMaker" : "6.17",
"File::Temp" : "0.13",
"Test::More" : "0.45",
- "parent" : "0.221"
+ "parent" : "0.221",
+ "perl" : "5.006002"
}
}
},
"release_status" : "stable",
- "version" : "0.9904"
+ "version" : "0.9908"
}
@@ -7,7 +7,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.112621'
+generated_by: 'ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.120351'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -18,7 +18,9 @@ no_index:
- t
- inc
requires:
+ ExtUtils::MakeMaker: 6.17
File::Temp: 0.13
Test::More: 0.45
parent: 0.221
-version: 0.9904
+ perl: 5.006002
+version: 0.9908
@@ -5,17 +5,20 @@
use strict;
-use ExtUtils::MakeMaker;
use Config qw(%Config);
-use File::Spec;
-
-use vars qw ($no_xs $force_xs);
+use ExtUtils::MakeMaker;
+use File::Temp qw/tempdir tempfile/;
-if ( $] >= 5.009_001 && $] < 5.010_000 ) {
- die "The CPAN module cannot be tested with Perl $]\n".
- "Please update to the latest bleadperl...";
+if ($] < 5.006002) {
+ die <<'EOL'
+Perl 5.006002 required. Please install version-0.9906 if you need
+to support an earlier Perl release.
+EOL
}
+use vars qw ($no_xs $force_xs);
+unlink 'pm_to_blib'; # belts and braces
+
if ($ENV{PERL_ONLY}) {
$no_xs = 1;
}
@@ -24,15 +27,18 @@ for (@ARGV)
{
/^--perl_only/ and $no_xs = 1;
/^--perl-only/ and $no_xs = 1;
- /^--xs/ and $no_xs = 0;
+ /^--xs/ and $force_xs = 1;
}
-map { unlink $_ if -f $_ } <vutil/Makefile*>;
+if ($] < 5.010) { # support pure Perl only
+ $no_xs = 1;
+}
-unless (defined $no_xs)
+unless (defined $no_xs or $force_xs)
{
check_for_compiler()
or no_cc();
+
}
write_makefile();
@@ -40,63 +46,57 @@ write_makefile();
sub write_makefile
{
my %prereq = (
- 'Test::More' => 0.45,
- 'File::Temp' => 0.13,
- 'parent' => 0.221,
+ 'ExtUtils::MakeMaker' => 6.17,
+ 'Test::More' => 0.45,
+ 'File::Temp' => 0.13,
+ 'parent' => 0.221,
);
WriteMakefile( VERSION_FROM => 'lib/version.pm',
NAME => 'version',
LICENSE => 'perl',
+ MIN_PERL_VERSION=> 5.006002,
PREREQ_PM => \%prereq,
- CONFIGURE => \&init,
- ( $] >= 5.005 ?
- ( ABSTRACT => 'Structured version objects',
- AUTHOR => 'John Peacock <jpeacock@cpan.org>') :
+ NORECURS => $no_xs,
+ ABSTRACT => 'Structured version objects',
+ AUTHOR => 'John Peacock <jpeacock@cpan.org>',
+ ( $] >= 5.009001 && $] < 5.011000 ?
+ ( INSTALLDIRS => 'perl' ) :
()
- ),
- ( $] >= 5.009001 && $] < 5.011000 ?
- ( INSTALLDIRS => 'perl' ) :
+ ),
+ ( ($] < 5.012
+ && ! $ENV{PERL_NO_HIGHLANDER}
+ && ! ( $ENV{PERL_MM_OPT}
+ && $ENV{PERL_MM_OPT} =~ /(?:INSTALL_BASE|PREFIX)/ )
+ && ! grep { /INSTALL_BASE/ || /PREFIX/ } @ARGV ) ?
+ ( UNINST => 1 ) :
()
),
- PM =>
+ PM =>
{'lib/version.pm' => '$(INST_LIBDIR)/version.pm',
'lib/version.pod' => '$(INST_LIBDIR)/version.pod',
+ 'lib/version/regex.pm' =>
+ '$(INST_LIBDIR)/version/regex.pm',
'lib/version/Internals.pod' =>
- '$(INST_LIBDIR)/version/Internals.pod'},
+ '$(INST_LIBDIR)/version/Internals.pod',
+ 'vperl/vpp.pm' => '$(INST_LIBDIR)/version/vpp.pm',
+ },
PL_FILES => {},
C => [],
- clean => { FILES => 'vutil/Makefile.PL' },
+ ( $no_xs ?
+ () :
+ ( DIR => ['vutil'])
+ ),
dist => {
- COMPRESS => 'gzip -9f',
+ COMPRESS => 'gzip -9f',
SUFFIX => 'gz',
PREOP => (
'hg log --style changelog > Changes'
),
},
-
);
}
-sub init
-{
- my $hash = $_[1];
-
- # include this always
- $hash->{'PM'}->{'vperl/vpp.pm'} = '$(INST_LIBDIR)/version/vpp.pm';
- unless ($no_xs) {
- open MAKEFILE, '>vutil/Makefile.PL';
- while (<DATA>) {
- print MAKEFILE $_;
- }
- close MAKEFILE;
- sleep(1);
- @{ $hash }{ 'DIR' } = ['vutil'];
- }
-
- return $hash;
-}
-
sub no_cc
{
$no_xs = 1;
@@ -115,6 +115,13 @@ EOF
sub check_for_compiler
{
+ # IMPORTANT NOTE: This is NOT used to determine how to compile
+ # extensions properly; EU::MM does that for us. This is only
+ # intended to see if that is likely to succeed. We do not try
+ # to do anything here except compile (not even link). If you
+ # want this to be a full featured test, feel free to submit a
+ # patch or do something useful.
+
print "Testing if you have a C compiler\n";
eval { require ExtUtils::CBuilder };
@@ -149,23 +156,22 @@ EOF
close F or return 0;
- my $cc = $Config{cc};
+ my ($cc, $ccflags, $obj_ext) = map { $Config{$_} } qw/cc ccflags obj_ext/;
- my $retval = system( "$cc -c -o test$Config{obj_ext} test.c" );
- map { unlink $_ if -f $_ } ('test.c',"test$Config{obj_ext}");
+ my $command;
+ if ($^O =~ /(dos|win32)/i && $Config{'cc'} =~ /^cl/) {
+ $command = "$cc $ccflags /c test.c";
+ }
+ elsif ($Config{gccversion}) {
+ $command = "$cc $ccflags -o test$obj_ext test.c";
+ }
+ else {
+ warn "Unsupported system: can't test compiler availability. Patches welcome...";
+ return 0;
+ }
+
+ my $retval = system( $command );
+ map { unlink $_ if -f $_ } ('test.c',"test$obj_ext");
return not($retval); # system returns -1
}
-
-__DATA__
-#!/usr/bin/perl -w
-use strict;
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- NAME => 'version::vxs',
- AUTHOR => 'John Peacock <jpeacock@cpan.org>',
- VERSION_FROM => 'lib/version/vxs.pm',
- OBJECT => q/$(O_FILES)/,
- TYPEMAPS => ['../lib/version/typemap'],
-);
@@ -1,4 +1,4 @@
-version 0.9904
+version 0.9908
==================================
Full version object support, with patch for bug in Perl 5.10.0 core
@@ -9,6 +9,49 @@ There was a bug caused by objects serialized by YAML that will cause Perl
5.10.0 to segfault. As long as some module calls 'use version', then the
replacement code will take effect and Perl will not crash.
+IMPORTANT NOTE - 0.9906 is the last release that fully supports Perl
+releases prior to 5.6.2. It is just too much trouble to continue to
+fight to maintain full backward compatibility.
+
+Major Changes in 0.9908 - 2014-02-02
+=====================================
+More optimizations courtesy of Daniel Dragan (bulk88@hotmail.com).
+Also resolves:
+ https://rt.cpan.org/Ticket/Display.html?id=92438
+ https://rt.cpan.org/Ticket/Display.html?id=92540
+ https://rt.cpan.org/Ticket/Display.html?id=92642
+
+Major Changes in 0.9907 - 2014-01-12
+=====================================
+Lots of optimizations of XS and C code courtesy of Daniel Dragan
+(bulk88@hotmail.com). Lots of minor tweaks as well.
+
+Resolves:
+ https://rt.cpan.org/Ticket/Display.html?id=91892
+ https://rt.cpan.org/Ticket/Display.html?id=91867
+ https://rt.cpan.org/Ticket/Display.html?id=91987
+ https://rt.cpan.org/Ticket/Display.html?id=92051
+
+Major Changes in 0.9906 - 2014-01-04
+=====================================
+Applied C89 compatibility fix from Karl Williamson to vxs.inc. Added back
+support for $version::LAX and $version::STRICT to resolve:
+
+ https://rt.cpan.org/Ticket/Display.html?id=88458
+ https://rt.cpan.org/Ticket/Display.html?id=91858
+ https://rt.cpan.org/Ticket/Display.html?id=91868
+
+Major Changes in 0.9905 - 2014-01-04
+=====================================
+Major rewrite of XS code to permit easier inclusion in core Perl (mostly
+written by Father Chrysostomos <sprout@cpan.org>). XS code is no longer
+supported for any Perl < v5.10, although the pure Perl code still works
+going back to 5.005_04.
+
+In addition, the version::vpp class is now completely independent and can
+be use'd exactly like the base version class. It is still better to use
+the base class for compatibility purposes.
+
Major Changes in 0.9904 - 2013-08-20
=====================================
Final upstream changes from bleadperl. Resolves RT tickets:
@@ -129,7 +129,7 @@ was used to initialize the version object.
=head2 Regular Expressions for Version Parsing
A formalized definition of the legal forms for version strings is
-included in the main F<version.pm> file. Primitives are included for
+included in the C<version::regex> class. Primitives are included for
common elements, although they are scoped to the file so they are useful
for reference purposes only. There are two publicly accessible scalars
that can be used in other code (not exported):
@@ -0,0 +1,117 @@
+package version::regex;
+
+use strict;
+
+use vars qw($VERSION $CLASS $STRICT $LAX);
+
+$VERSION = 0.9908;
+
+#--------------------------------------------------------------------------#
+# Version regexp components
+#--------------------------------------------------------------------------#
+
+# Fraction part of a decimal version number. This is a common part of
+# both strict and lax decimal versions
+
+my $FRACTION_PART = qr/\.[0-9]+/;
+
+# First part of either decimal or dotted-decimal strict version number.
+# Unsigned integer with no leading zeroes (except for zero itself) to
+# avoid confusion with octal.
+
+my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
+
+# First part of either decimal or dotted-decimal lax version number.
+# Unsigned integer, but allowing leading zeros. Always interpreted
+# as decimal. However, some forms of the resulting syntax give odd
+# results if used as ordinary Perl expressions, due to how perl treats
+# octals. E.g.
+# version->new("010" ) == 10
+# version->new( 010 ) == 8
+# version->new( 010.2) == 82 # "8" . "2"
+
+my $LAX_INTEGER_PART = qr/[0-9]+/;
+
+# Second and subsequent part of a strict dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal.
+# Limited to three digits to avoid overflow when converting to decimal
+# form and also avoid problematic style with excessive leading zeroes.
+
+my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
+
+# Second and subsequent part of a lax dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal. No
+# limit on the numerical value or number of digits, so there is the
+# possibility of overflow when converting to decimal form.
+
+my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
+
+# Alpha suffix part of lax version number syntax. Acts like a
+# dotted-decimal part.
+
+my $LAX_ALPHA_PART = qr/_[0-9]+/;
+
+#--------------------------------------------------------------------------#
+# Strict version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Strict decimal version number.
+
+my $STRICT_DECIMAL_VERSION =
+ qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
+
+# Strict dotted-decimal version number. Must have both leading "v" and
+# at least three parts, to avoid confusion with decimal syntax.
+
+my $STRICT_DOTTED_DECIMAL_VERSION =
+ qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
+
+# Complete strict version number syntax -- should generally be used
+# anchored: qr/ \A $STRICT \z /x
+
+$STRICT =
+ qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+# Lax version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Lax decimal version number. Just like the strict one except for
+# allowing an alpha suffix or allowing a leading or trailing
+# decimal-point
+
+my $LAX_DECIMAL_VERSION =
+ qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
+ |
+ $FRACTION_PART $LAX_ALPHA_PART?
+ /x;
+
+# Lax dotted-decimal version number. Distinguished by having either
+# leading "v" or at least three non-alpha parts. Alpha part is only
+# permitted if there are at least two non-alpha parts. Strangely
+# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
+# so when there is no "v", the leading part is optional
+
+my $LAX_DOTTED_DECIMAL_VERSION =
+ qr/
+ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
+ |
+ $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
+ /x;
+
+# Complete lax version number syntax -- should generally be used
+# anchored: qr/ \A $LAX \z /x
+#
+# The string 'undef' is a special case to make for easier handling
+# of return values from ExtUtils::MM->parse_version
+
+$LAX =
+ qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+
+# Preloaded methods go here.
+sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
+sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
+
+1;
@@ -1,29 +0,0 @@
-###############################################################################
-## ##
-## Typemap for module "Universal::Version" ##
-## ##
-## Copyright (c) 2001 by John Peacock. ##
-## All rights reserved. ##
-## ##
-## This package is free software; you can redistribute it ##
-## and/or modify it under the same terms as Perl itself. ##
-## ##
-###############################################################################
-
-TYPEMAP
-
-N_int T_IV
-N_long T_IV
-Z_int T_IV
-Z_long T_IV
-boolean T_IV
-version_vxs T_PTROBJ_SPECIAL
-
-INPUT
-
-T_PTROBJ_SPECIAL
- if (ISA_CLASS_OBJ($arg, \"version\")) {
- $var = SvRV($arg);
- }
- else
- Perl_croak(aTHX_ \"$var is not of type ${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\")
@@ -1,119 +1,15 @@
#!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.9904;
-
+$VERSION = 0.9908;
$CLASS = 'version';
-#--------------------------------------------------------------------------#
-# Version regexp components
-#--------------------------------------------------------------------------#
-
-# Fraction part of a decimal version number. This is a common part of
-# both strict and lax decimal versions
-
-my $FRACTION_PART = qr/\.[0-9]+/;
-
-# First part of either decimal or dotted-decimal strict version number.
-# Unsigned integer with no leading zeroes (except for zero itself) to
-# avoid confusion with octal.
-
-my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
-
-# First part of either decimal or dotted-decimal lax version number.
-# Unsigned integer, but allowing leading zeros. Always interpreted
-# as decimal. However, some forms of the resulting syntax give odd
-# results if used as ordinary Perl expressions, due to how perl treats
-# octals. E.g.
-# version->new("010" ) == 10
-# version->new( 010 ) == 8
-# version->new( 010.2) == 82 # "8" . "2"
-
-my $LAX_INTEGER_PART = qr/[0-9]+/;
-
-# Second and subsequent part of a strict dotted-decimal version number.
-# Leading zeroes are permitted, and the number is always decimal.
-# Limited to three digits to avoid overflow when converting to decimal
-# form and also avoid problematic style with excessive leading zeroes.
-
-my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
-
-# Second and subsequent part of a lax dotted-decimal version number.
-# Leading zeroes are permitted, and the number is always decimal. No
-# limit on the numerical value or number of digits, so there is the
-# possibility of overflow when converting to decimal form.
-
-my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
-
-# Alpha suffix part of lax version number syntax. Acts like a
-# dotted-decimal part.
-
-my $LAX_ALPHA_PART = qr/_[0-9]+/;
-
-#--------------------------------------------------------------------------#
-# Strict version regexp definitions
-#--------------------------------------------------------------------------#
-
-# Strict decimal version number.
-
-my $STRICT_DECIMAL_VERSION =
- qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
-
-# Strict dotted-decimal version number. Must have both leading "v" and
-# at least three parts, to avoid confusion with decimal syntax.
-
-my $STRICT_DOTTED_DECIMAL_VERSION =
- qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
-
-# Complete strict version number syntax -- should generally be used
-# anchored: qr/ \A $STRICT \z /x
-
-$STRICT =
- qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
-
-#--------------------------------------------------------------------------#
-# Lax version regexp definitions
-#--------------------------------------------------------------------------#
-
-# Lax decimal version number. Just like the strict one except for
-# allowing an alpha suffix or allowing a leading or trailing
-# decimal-point
-
-my $LAX_DECIMAL_VERSION =
- qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
- |
- $FRACTION_PART $LAX_ALPHA_PART?
- /x;
-
-# Lax dotted-decimal version number. Distinguished by having either
-# leading "v" or at least three non-alpha parts. Alpha part is only
-# permitted if there are at least two non-alpha parts. Strangely
-# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
-# so when there is no "v", the leading part is optional
-
-my $LAX_DOTTED_DECIMAL_VERSION =
- qr/
- v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
- |
- $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
- /x;
-
-# Complete lax version number syntax -- should generally be used
-# anchored: qr/ \A $LAX \z /x
-#
-# The string 'undef' is a special case to make for easier handling
-# of return values from ExtUtils::MM->parse_version
-
-$LAX =
- qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
-
-#--------------------------------------------------------------------------#
-
+# !!!!Delete this next block completely when adding to Perl core!!!!
{
local $SIG{'__DIE__'};
eval "use version::vxs $VERSION";
@@ -150,20 +46,25 @@ $LAX =
*{'version::(<=>'} = \&version::vxs::VCMP;
*version::parse = \&version::vxs::parse;
}
-
}
}
-# Preloaded methods go here.
+# avoid using Exporter
+require version::regex;
+*version::is_lax = \&version::regex::is_lax;
+*version::is_strict = \&version::regex::is_strict;
+*LAX = \$version::regex::LAX;
+*STRICT = \$version::regex::STRICT;
+
sub import {
no strict 'refs';
my ($class) = shift;
# Set up any derived class
- unless ($class eq 'version') {
+ unless ($class eq $CLASS) {
local $^W;
- *{$class.'::declare'} = \&version::declare;
- *{$class.'::qv'} = \&version::qv;
+ *{$class.'::declare'} = \&{$CLASS.'::declare'};
+ *{$class.'::qv'} = \&{$CLASS.'::qv'};
}
my %args;
@@ -195,25 +96,23 @@ sub import {
if (exists($args{'UNIVERSAL::VERSION'})) {
local $^W;
*UNIVERSAL::VERSION
- = \&version::_VERSION;
+ = \&{$CLASS.'::_VERSION'};
}
if (exists($args{'VERSION'})) {
- *{$callpkg.'::VERSION'} = \&version::_VERSION;
+ *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
}
if (exists($args{'is_strict'})) {
- *{$callpkg.'::is_strict'} = \&version::is_strict
+ *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
unless defined(&{$callpkg.'::is_strict'});
}
if (exists($args{'is_lax'})) {
- *{$callpkg.'::is_lax'} = \&version::is_lax
+ *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
unless defined(&{$callpkg.'::is_lax'});
}
}
-sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
-sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
1;
@@ -0,0 +1,18 @@
+#! /usr/local/perl -w
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+#########################
+
+use Test::More qw/no_plan/;
+
+BEGIN {
+ (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
+ require $coretests;
+ use_ok('version::vpp', 0.9908);
+}
+
+BaseTests("version::vpp","new","qv");
+BaseTests("version::vpp","new","declare");
+BaseTests("version::vpp","parse", "qv");
+BaseTests("version::vpp","parse", "declare");
@@ -9,7 +9,7 @@ use Test::More qw/no_plan/;
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok('version', 0.9904);
+ use_ok('version', 0.9908);
}
BaseTests("version","new","qv");
@@ -10,19 +10,19 @@ use File::Temp qw/tempfile/;
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok("version", 0.9904);
+ use_ok("version", 0.9908);
# If we made it this far, we are ok.
}
use lib qw/./;
package version::Bad;
-use base 'version';
+use parent 'version';
sub new { my($self,$n)=@_; bless \$n, $self }
# Bad subclass for SemVer failures seen with pure Perl version.pm only
package version::Bad2;
-use base 'version';
+use parent 'version';
sub new {
my ($class, $val) = @_;
die 'Invalid version string format' unless version::is_strict($val);
@@ -45,7 +45,7 @@ my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
print $fh <<"EOF";
# This is an empty subclass
package $package;
-use base 'version';
+use parent 'version';
use vars '\$VERSION';
\$VERSION=0.001;
EOF
@@ -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.9904, "Make sure we have the correct class";
+is $version::VERSION, 0.9908, "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()");
@@ -8,11 +8,14 @@ use Test::More qw/no_plan/;
# do strict lax tests in a sub to isolate a package to test importing
SKIP: {
- skip 'No extended regexes Perl < 5.006', 172
+ skip 'No extended regexes Perl < 5.006', 174
if $] < 5.006_000;
strict_lax_tests();
+ is ref($version::LAX), 'Regexp', 'Can see $version::LAX '.$version::LAX ;
+ is ref($version::STRICT), 'Regexp', 'Can see $version::STRICT '.$version::STRICT;
}
+
sub strict_lax_tests {
package temp12345;
# copied from perl core test t/op/packagev.t
@@ -14,7 +14,7 @@ BEGIN {
}
BEGIN {
- use version 0.9904;
+ use version 0.9908;
}
pass "Didn't get caught by the wrong DIE handler, which is a good thing";
@@ -7,7 +7,7 @@
use Test::More qw/no_plan/;
BEGIN {
- use_ok('version', 0.9904);
+ use_ok('version', 0.9908);
}
my $v1 = version->new('1.2');
@@ -11,7 +11,7 @@ use Test::More tests => 7;
use Config;
BEGIN {
- use_ok('version', 0.9904);
+ use_ok('version', 0.9908);
}
SKIP: {
@@ -22,8 +22,6 @@ SKIP: {
# test locale handling
my $warning;
- use locale;
-
local $SIG{__WARN__} = sub { $warning = $_[0] };
my $ver = 1.23; # has to be floating point number
@@ -33,10 +31,12 @@ SKIP: {
# because have to
# evaluate in current
# scope
+ use if $^O !~ /android/, 'locale';
+
while (<DATA>) {
chomp;
$loc = setlocale( LC_ALL, $_);
- last if localeconv()->{decimal_point} eq ',';
+ last if $loc && localeconv()->{decimal_point} eq ',';
}
skip 'Cannot test locale handling without a comma locale', 5
unless $loc and localeconv()->{decimal_point} eq ',';
@@ -5,7 +5,7 @@
#########################
use Test::More tests => 3;
-use_ok("version", 0.9904);
+use_ok("version", 0.9908);
# do strict lax tests in a sub to isolate a package to test importing
SKIP: {
@@ -0,0 +1,40 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+#########################
+
+use strict;
+use_ok("version", 0.9908);
+use Test::More;
+
+BEGIN {
+ eval "use List::Util qw(reduce)";
+ if ($@) {
+ plan skip_all => "No List::Util::reduce() available";
+ } else {
+ plan tests => 3;
+ }
+}
+
+# do strict lax tests in a sub to isolate a package to test importing
+# use again to get the import()
+use List::Util qw(reduce);
+{
+ my $fail = 0;
+ my $ret = reduce {
+ version->parse($a);
+ $fail++ unless defined $a;
+ 1
+ } "0.039", "0.035";
+ is $fail, 0, 'reduce() with parse';
+}
+
+{
+ my $fail = 0;
+ my $ret = reduce {
+ version->qv($a);
+ $fail++ unless defined $a;
+ 1
+ } "0.039", "0.035";
+ is $fail, 0, 'reduce() with qv';
+}
@@ -30,6 +30,10 @@ sub BaseTests {
$version = $CLASS->$method(1.23);
is ( "$version" , "1.23" , '1.23 eq "1.23"' );
+ # Test explicit integer
+ $version = $CLASS->$method(23);
+ is ( "$version" , 23 , '23 eq "23"' );
+
# Test quoted number processing
$version = $CLASS->$method("5.005_03");
is ( "$version" , "5.005_03" , '"5.005_03" eq "5.005_03"' );
@@ -426,13 +430,13 @@ EOF
}
SKIP: {
- skip 'Cannot test "use parent qw(version)" when require is used', 3
+ skip "Cannot test \"use parent $CLASS\" when require is used", 3
unless defined $qv_declare;
my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
(my $package = basename($filename)) =~ s/\.pm$//;
print $fh <<"EOF";
package $package;
-use parent qw(version);
+use parent $CLASS;
1;
EOF
close $fh;
@@ -490,9 +494,9 @@ EOF
{
# http://rt.perl.org/rt3/Ticket/Display.html?id=56606
- my $badv = bless { version => [1,2,3] }, "version";
+ my $badv = bless { version => [1,2,3] }, $CLASS;
is $badv, '1.002003', "Deal with badly serialized versions from YAML";
- my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
+ my $badv2 = bless { qv => 1, version => [1,2,3] }, $CLASS;
is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";
}
@@ -576,6 +580,19 @@ SKIP: {
is $v->numify, '0.520', 'Correctly nummified';
}
+ { # https://rt.cpan.org/Ticket/Display.html?id=88495
+ @ver::ISA = $CLASS;
+ is ref(ver->new), 'ver', 'ver can inherit from version';
+ is ref(ver->qv("1.2.3")), 'ver', 'ver can inherit from version';
+ }
+
+ { # discovered while integrating with bleadperl
+ eval {my $v = $CLASS->new([1,2,3]) };
+ like $@, qr/Invalid version format/, 'Do not crash for garbage';
+ eval {my $v = $CLASS->new({1 => 2}) };
+ like $@, qr/Invalid version format/, 'Do not crash for garbage';
+ }
+
}
1;
@@ -116,12 +116,20 @@ sub currstr {
}
package version::vpp;
+
+use 5.006002;
use strict;
-use POSIX qw/locale_h/;
-use locale;
-use vars qw ($VERSION @ISA @REGEXS);
-$VERSION = 0.9904;
+use Config;
+use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
+$VERSION = 0.9908;
+$CLASS = 'version::vpp';
+
+require version::regex;
+*version::vpp::is_strict = \&version::regex::is_strict;
+*version::vpp::is_lax = \&version::regex::is_lax;
+*LAX = \$version::regex::LAX;
+*STRICT = \$version::regex::STRICT;
use overload (
'""' => \&stringify,
@@ -150,6 +158,64 @@ if ($@) {
';
}
+sub import {
+ no strict 'refs';
+ my ($class) = shift;
+
+ # Set up any derived class
+ unless ($class eq $CLASS) {
+ local $^W;
+ *{$class.'::declare'} = \&{$CLASS.'::declare'};
+ *{$class.'::qv'} = \&{$CLASS.'::qv'};
+ }
+
+ my %args;
+ if (@_) { # any remaining terms are arguments
+ map { $args{$_} = 1 } @_
+ }
+ else { # no parameters at all on use line
+ %args =
+ (
+ qv => 1,
+ 'UNIVERSAL::VERSION' => 1,
+ );
+ }
+
+ my $callpkg = caller();
+
+ if (exists($args{declare})) {
+ *{$callpkg.'::declare'} =
+ sub {return $class->declare(shift) }
+ unless defined(&{$callpkg.'::declare'});
+ }
+
+ if (exists($args{qv})) {
+ *{$callpkg.'::qv'} =
+ sub {return $class->qv(shift) }
+ unless defined(&{$callpkg.'::qv'});
+ }
+
+ if (exists($args{'UNIVERSAL::VERSION'})) {
+ local $^W;
+ *UNIVERSAL::VERSION
+ = \&{$CLASS.'::_VERSION'};
+ }
+
+ if (exists($args{'VERSION'})) {
+ *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
+ }
+
+ if (exists($args{'is_strict'})) {
+ *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
+ unless defined(&{$callpkg.'::is_strict'});
+ }
+
+ if (exists($args{'is_lax'})) {
+ *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
+ unless defined(&{$callpkg.'::is_lax'});
+ }
+}
+
my $VERSION_MAX = 0x7FFFFFFF;
# implement prescan_version as closely to the C version as possible
@@ -412,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);
}
}
@@ -568,25 +634,49 @@ sub scan_version {
return $s;
}
-sub new
-{
- my ($class, $value) = @_;
- unless (defined $class) {
- require Carp;
- Carp::croak('Usage: version::new(class, version)');
- }
- my $self = bless ({}, ref ($class) || $class);
- my $qv = FALSE;
+sub new {
+ my $class = shift;
+ unless (defined $class or $#_ > 1) {
+ require Carp;
+ Carp::croak('Usage: version::new(class, version)');
+ }
- if ( ref($value) && eval('$value->isa("version")') ) {
- # Can copy the elements directly
- $self->{version} = [ @{$value->{version} } ];
- $self->{qv} = 1 if $value->{qv};
- $self->{alpha} = 1 if $value->{alpha};
- $self->{original} = ''.$value->{original};
- return $self;
- }
+ my $self = bless ({}, ref ($class) || $class);
+ my $qv = FALSE;
+
+ if ( $#_ == 1 ) { # must be CVS-style
+ $qv = TRUE;
+ }
+ my $value = pop; # always going to be the last element
+
+ if ( ref($value) && eval('$value->isa("version")') ) {
+ # Can copy the elements directly
+ $self->{version} = [ @{$value->{version} } ];
+ $self->{qv} = 1 if $value->{qv};
+ $self->{alpha} = 1 if $value->{alpha};
+ $self->{original} = ''.$value->{original};
+ return $self;
+ }
+
+ if ( not defined $value or $value =~ /^undef$/ ) {
+ # RT #19517 - special case for undef comparison
+ # or someone forgot to pass a value
+ push @{$self->{version}}, 0;
+ $self->{original} = "0";
+ return ($self);
+ }
+
+ if (ref($value) =~ m/ARRAY|HASH/) {
+ require Carp;
+ Carp::croak("Invalid version format (non-numeric data)");
+ }
+
+ $value = _un_vstring($value);
+
+ 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
@@ -595,42 +685,27 @@ sub new
if ( localeconv()->{decimal_point} eq ',' ) {
$value =~ tr/,/./;
}
+ }
- if ( not defined $value or $value =~ /^undef$/ ) {
- # RT #19517 - special case for undef comparison
- # or someone forgot to pass a value
- push @{$self->{version}}, 0;
- $self->{original} = "0";
- return ($self);
- }
-
- if ( $#_ == 2 ) { # must be CVS-style
- $value = $_[2];
- $qv = TRUE;
- }
-
- $value = _un_vstring($value);
-
- # exponential notation
- if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
- $value = sprintf("%.9f",$value);
- $value =~ s/(0+)$//; # trim trailing zeros
- }
+ # exponential notation
+ if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
+ $value = sprintf("%.9f",$value);
+ $value =~ s/(0+)$//; # trim trailing zeros
+ }
- my $s = scan_version($value, \$self, $qv);
+ my $s = scan_version($value, \$self, $qv);
- if ($s) { # must be something left over
- warn("Version string '%s' contains invalid data; "
- ."ignoring: '%s'", $value, $s);
- }
+ if ($s) { # must be something left over
+ warn("Version string '%s' contains invalid data; "
+ ."ignoring: '%s'", $value, $s);
+ }
- return ($self);
+ return ($self);
}
*parse = \&new;
-sub numify
-{
+sub numify {
my ($self) = @_;
unless (_verify($self)) {
require Carp;
@@ -670,8 +745,7 @@ sub numify
return $string;
}
-sub normal
-{
+sub normal {
my ($self) = @_;
unless (_verify($self)) {
require Carp;
@@ -706,8 +780,7 @@ sub normal
return $string;
}
-sub stringify
-{
+sub stringify {
my ($self) = @_;
unless (_verify($self)) {
require Carp;
@@ -720,8 +793,7 @@ sub stringify
: $self->numify;
}
-sub vcmp
-{
+sub vcmp {
require UNIVERSAL;
my ($left,$right,$swap) = @_;
my $class = ref($left);
@@ -806,7 +878,7 @@ sub is_alpha {
sub qv {
my $value = shift;
- my $class = 'version';
+ my $class = $CLASS;
if (@_) {
$class = ref($value) || $value;
$value = shift;
@@ -814,7 +886,7 @@ sub qv {
$value = _un_vstring($value);
$value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
- my $obj = version->new($value);
+ my $obj = $CLASS->new($value);
return bless $obj, $class;
}
@@ -0,0 +1,11 @@
+#!/usr/bin/perl -w
+use strict;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'version::vxs',
+ AUTHOR => 'John Peacock <jpeacock@cpan.org>',
+ VERSION_FROM => 'lib/version/vxs.pm',
+ OBJECT => q/$(O_FILES)/,
+ depend => { qw< vxs.c vxs.inc > },
+);
@@ -1,13 +1,11 @@
#!perl -w
package version::vxs;
-use 5.005_03;
+use v5.10;
use strict;
use vars qw(@ISA $VERSION $CLASS );
-
-$VERSION = 0.9904;
-
+$VERSION = 0.9908;
$CLASS = 'version::vxs';
eval {
@@ -1,12 +1,18 @@
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#define NEED_my_snprintf
-#define NEED_newRV_noinc
-#define NEED_vnewSVpvf
-#define NEED_newSVpvn_flags_GLOBAL
-#define NEED_warner
-#include "ppport.h"
+/* This file is part of the "version" CPAN distribution. Please avoid
+ editing it in the perl core. */
+
+#ifndef PERL_CORE
+# define PERL_NO_GET_CONTEXT
+# include "EXTERN.h"
+# include "perl.h"
+# include "XSUB.h"
+# define NEED_my_snprintf
+# define NEED_newRV_noinc
+# define NEED_vnewSVpvf
+# define NEED_newSVpvn_flags_GLOBAL
+# define NEED_warner
+# include "ppport.h"
+#endif
#include "vutil.h"
#define VERSION_MAX 0x7FFFFFFF
@@ -278,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);
}
}
@@ -391,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:
@@ -427,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;
}
@@ -457,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();
@@ -478,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));
}
@@ -507,21 +512,21 @@ 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
- sv_setsv(rv,ver); /* make a duplicate */
+ SvSetSV_nosteal(rv, ver); /* make a duplicate */
#ifdef SvVOK
}
}
#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));
}
/*
@@ -549,9 +554,30 @@ 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))
+VER_IV:
+ {
+ version = savesvpv(ver);
+ SAVEFREEPV(version);
+ }
+ else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
+VER_NV:
{
STRLEN len;
@@ -559,42 +585,36 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
char tbuf[64];
SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
char *buf;
-#ifdef USE_LOCALE_NUMERIC
- char *loc = NULL;
- if (! PL_numeric_standard) {
- loc = savepv(setlocale(LC_NUMERIC, NULL));
- setlocale(LC_NUMERIC, "C");
- }
-#endif
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
if (sv) {
- Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
- buf = SvPV(sv, len);
+ Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
+ len = SvCUR(sv);
+ buf = SvPVX(sv);
}
else {
len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
buf = tbuf;
}
-#ifdef USE_LOCALE_NUMERIC
- if (loc) {
- setlocale(LC_NUMERIC, loc);
- Safefree(loc);
- }
-#endif
+ 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 /* must be a string or something like a string */
+ else if ( SvPOK(ver))/* must be a string or something like a string */
+VER_PV:
{
STRLEN len;
- version = savepv(SvPV(ver,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 */
@@ -611,6 +631,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' */
@@ -622,7 +643,6 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
/* is definitely a v-string */
if ( saw_decimal >= 2 ) {
- Safefree(version);
version = nver;
}
break;
@@ -632,13 +652,33 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
# 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_croak(aTHX_ "Invalid version format (non-numeric data)");
+ }
s = SCAN_VERSION(version, ver, qv);
if ( *s != '\0' )
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;
}
@@ -676,6 +716,7 @@ Perl_vverify(pTHX_ SV *vs)
#endif
{
SV *sv;
+ SV **svp;
PERL_ARGS_ASSERT_VVERIFY;
@@ -684,8 +725,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
@@ -732,10 +773,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 */
@@ -749,11 +793,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);
@@ -766,7 +814,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);
@@ -822,17 +871,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
@@ -866,6 +920,7 @@ Perl_vstringify2(pTHX_ SV *vs)
Perl_vstringify(pTHX_ SV *vs)
#endif
{
+ SV ** svp;
PERL_ARGS_ASSERT_VSTRINGIFY;
/* extract the HV from the object */
@@ -873,9 +928,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
@@ -938,8 +994,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 )
@@ -966,7 +1025,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++;
}
@@ -975,7 +1035,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++;
}
@@ -1,4 +1,9 @@
-#include "ppport.h"
+/* This file is part of the "version" CPAN distribution. Please avoid
+ editing it in the perl core. */
+
+#ifndef PERL_CORE
+# include "ppport.h"
+#endif
/* The MUTABLE_*() macros cast pointers to the types shown, in such a way
* (compiler permitting) that casting away const-ness will give a warning;
@@ -78,9 +83,51 @@ 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)
+#if PERL_VERSION_GE(5,9,0) && !defined(PERL_CORE)
# define VUTIL_REPLACE_CORE 1
@@ -104,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))
@@ -131,10 +180,14 @@ const char * Perl_prescan_version(pTHX_ const char *s, bool strict, const char**
# define VCMP(a,b) Perl_vcmp(aTHX_ a,b)
# define PRESCAN_VERSION(a,b,c,d,e,f,g) Perl_prescan_version(aTHX_ a,b,c,d,e,f,g)
-# define is_LAX_VERSION(a,b) \
+# ifndef is_LAX_VERSION
+# define is_LAX_VERSION(a,b) \
(a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
-# define is_STRICT_VERSION(a,b) \
+# endif
+# ifndef is_STRICT_VERSION
+# define is_STRICT_VERSION(a,b) \
(a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
+# endif
#endif
@@ -168,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
@@ -0,0 +1,471 @@
+/* This file is part of the "version" CPAN distribution. Please avoid
+ editing it in the perl core. */
+
+#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))
+
+/* uses PUSHs, so SP must be at start, PUSHs sv on Perl stack, then returns from
+ xsub; this is a little more machine code/tailcall friendly than mPUSHs(foo);
+ PUTBACK; return; */
+
+#define VXS_RETURN_M_SV(sv) \
+ STMT_START { \
+ SV * sv_vtc = sv; \
+ PUSHs(sv_vtc); \
+ PUTBACK; \
+ sv_2mortal(sv_vtc); \
+ return; \
+ } STMT_END
+
+
+#ifdef VXS_XSUB_DETAILS
+# ifdef PERL_CORE
+ {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)},
+# endif
+ {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, VXSXSDP(NULL)},
+# else
+ {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(NULL)},
+# endif
+ {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
+# define dVAR
+#endif
+
+#ifdef HvNAME_HEK
+typedef HEK HVNAME;
+# ifndef HEKf
+# define HEKfARG(arg) ((void*)(sv_2mortal(newSVhek(arg))))
+# define HEKf SVf
+# endif
+#else
+typedef char HVNAME;
+# define HvNAME_HEK HvNAME_get
+# define HEKfARG(arg) arg
+# define HEKf "s"
+#endif
+
+VXS(universal_version)
+{
+ dVAR;
+ dXSARGS;
+ HV *pkg;
+ GV **gvp;
+ GV *gv;
+ SV *sv;
+ const char *undef;
+ PERL_UNUSED_ARG(cv);
+
+ if (items < 1)
+ Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
+
+ sv = ST(0);
+
+ if (SvROK(sv)) {
+ sv = (SV*)SvRV(sv);
+ if (!SvOBJECT(sv))
+ Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
+ pkg = SvSTASH(sv);
+ }
+ else {
+ pkg = gv_stashsv(sv, FALSE);
+ }
+
+ gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;
+
+ if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
+ sv = sv_mortalcopy(sv);
+ if ( ! ISA_VERSION_OBJ(sv) )
+ UPG_VERSION(sv, FALSE);
+ undef = NULL;
+ }
+ else {
+ sv = &PL_sv_undef;
+ undef = "(undef)";
+ }
+
+ if (items > 1) {
+ SV *req = ST(1);
+
+ if (undef) {
+ if (pkg) {
+ const HVNAME* const name = HvNAME_HEK(pkg);
+#if PERL_VERSION == 5
+ Perl_croak(aTHX_ "%s version %s required--this is only version ",
+ name, SvPVx_nolen_const(req));
+#else
+ Perl_croak(aTHX_
+ "%"HEKf" does not define $%"HEKf
+ "::VERSION--version check failed",
+ HEKfARG(name), HEKfARG(name));
+#endif
+ }
+ else {
+#if PERL_VERSION >= 8
+ Perl_croak(aTHX_
+ "%"SVf" defines neither package nor VERSION--version check failed",
+ (void*)(ST(0)) );
+#else
+ Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
+ SvPVx_nolen_const(ST(0)),
+ SvPVx_nolen_const(ST(0)) );
+#endif
+ }
+ }
+
+ if ( ! ISA_VERSION_OBJ(req) ) {
+ /* req may very well be R/O, so create a new object */
+ req = sv_2mortal( NEW_VERSION(req) );
+ }
+
+ if ( VCMP( req, sv ) > 0 ) {
+ if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
+ req = VNORMAL(req);
+ sv = VNORMAL(sv);
+ }
+ else {
+ req = VSTRINGIFY(req);
+ sv = VSTRINGIFY(sv);
+ }
+ Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
+ "this is only version %"SVf"", HEKfARG(HvNAME_HEK(pkg)),
+ SVfARG(sv_2mortal(req)),
+ SVfARG(sv_2mortal(sv)));
+ }
+ }
+
+ /* if the package's $VERSION is not undef, it is upgraded to be a version object */
+ if (ISA_VERSION_OBJ(sv)) {
+ ST(0) = sv_2mortal(VSTRINGIFY(sv));
+ } else {
+ ST(0) = sv;
+ }
+
+ XSRETURN(1);
+}
+
+VXS(version_new)
+{
+ dVAR;
+ dXSARGS;
+ SV *vs;
+ SV *rv;
+ const char * classname = "";
+ STRLEN len;
+ U32 flags = 0;
+ SV * svarg0 = NULL;
+ PERL_UNUSED_VAR(cv);
+
+ SP -= items;
+
+ switch((U32)items) {
+ case 3: {
+ SV * svarg2;
+ vs = sv_newmortal();
+ svarg2 = ST(2);
+#if PERL_VERSION == 5
+ sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2));
+#else
+ Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
+#endif
+ break;
+ }
+ case 2:
+ vs = ST(1);
+ /* Just in case this is something like a tied hash */
+ SvGETMAGIC(vs);
+ if(SvOK(vs))
+ break;
+ /* drop through */
+ case 1:
+ /* no param or explicit undef */
+ /* create empty object */
+ vs = sv_newmortal();
+ sv_setpvs(vs,"undef");
+ break;
+ default:
+ case 0:
+ Perl_croak_nocontext("Usage: version::new(class, version)");
+ break;
+ }
+
+ svarg0 = ST(0);
+ if ( sv_isobject(svarg0) ) {
+ /* get the class if called as an object method */
+ const HV * stash = SvSTASH(SvRV(svarg0));
+ classname = HvNAME_get(stash);
+ len = HvNAMELEN_get(stash);
+#ifdef HvNAMEUTF8
+ flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+#endif
+ }
+ else {
+ classname = SvPV_nomg(svarg0, len);
+ flags = SvUTF8(svarg0);
+ }
+
+ rv = NEW_VERSION(vs);
+ if ( len != sizeof(VXS_CLASS)-1
+ || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
+#if PERL_VERSION == 5
+ sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
+#else
+ sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+#endif
+
+ VXS_RETURN_M_SV(rv);
+}
+
+#define VTYPECHECK(var, val, varname) \
+ STMT_START { \
+ SV * sv_vtc = val; \
+ if (ISA_VERSION_OBJ(sv_vtc)) { \
+ (var) = SvRV(sv_vtc); \
+ } \
+ else \
+ Perl_croak_nocontext(varname " is not of type version"); \
+ } STMT_END
+
+VXS(version_stringify)
+{
+ dVAR;
+ dXSARGS;
+ if (items < 1)
+ croak_xs_usage(cv, "lobj, ...");
+ SP -= items;
+ {
+ SV * lobj;
+ VTYPECHECK(lobj, ST(0), "lobj");
+
+ VXS_RETURN_M_SV(VSTRINGIFY(lobj));
+ }
+}
+
+VXS(version_numify)
+{
+ dVAR;
+ dXSARGS;
+ if (items < 1)
+ croak_xs_usage(cv, "lobj, ...");
+ SP -= items;
+ {
+ SV * lobj;
+ VTYPECHECK(lobj, ST(0), "lobj");
+ VXS_RETURN_M_SV(VNUMIFY(lobj));
+ }
+}
+
+VXS(version_normal)
+{
+ dVAR;
+ dXSARGS;
+ if (items != 1)
+ croak_xs_usage(cv, "ver");
+ SP -= items;
+ {
+ SV * ver;
+ VTYPECHECK(ver, ST(0), "ver");
+
+ VXS_RETURN_M_SV(VNORMAL(ver));
+ }
+}
+
+VXS(version_vcmp)
+{
+ dVAR;
+ dXSARGS;
+ if (items < 1)
+ croak_xs_usage(cv, "lobj, ...");
+ SP -= items;
+ {
+ SV * lobj;
+ VTYPECHECK(lobj, ST(0), "lobj");
+ {
+ SV *rs;
+ SV *rvs;
+ SV * robj = ST(1);
+ const IV swap = (IV)SvIV(ST(2));
+
+ if ( !ISA_VERSION_OBJ(robj) )
+ {
+ robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)));
+ }
+ rvs = SvRV(robj);
+
+ if ( swap )
+ {
+ rs = newSViv(VCMP(rvs,lobj));
+ }
+ else
+ {
+ rs = newSViv(VCMP(lobj,rvs));
+ }
+
+ VXS_RETURN_M_SV(rs);
+ }
+ }
+}
+
+VXS(version_boolean)
+{
+ dVAR;
+ dXSARGS;
+ SV *lobj;
+ if (items < 1)
+ croak_xs_usage(cv, "lobj, ...");
+ SP -= items;
+ VTYPECHECK(lobj, ST(0), "lobj");
+ {
+ SV * const rs =
+ newSViv( VCMP(lobj,
+ sv_2mortal(NEW_VERSION(
+ sv_2mortal(newSVpvs("0"))
+ ))
+ )
+ );
+ VXS_RETURN_M_SV(rs);
+ }
+}
+
+VXS(version_noop)
+{
+ dVAR;
+ dXSARGS;
+ if (items < 1)
+ croak_xs_usage(cv, "lobj, ...");
+ 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;
+}
+
+static
+void
+S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
+{
+ dVAR;
+ dXSARGS;
+ if (items != 1)
+ croak_xs_usage(cv, "lobj");
+ {
+ SV *lobj = POPs;
+ SV *ret;
+ VTYPECHECK(lobj, lobj, "lobj");
+ if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) )
+ ret = &PL_sv_yes;
+ else
+ ret = &PL_sv_no;
+ PUSHs(ret);
+ PUTBACK;
+ return;
+ }
+}
+
+VXS(version_is_alpha)
+{
+ S_version_check_key(aTHX_ cv, "alpha", 5);
+}
+
+VXS(version_qv)
+{
+ dVAR;
+ dXSARGS;
+ PERL_UNUSED_ARG(cv);
+ SP -= items;
+ {
+ SV * ver = ST(0);
+ SV * sv0 = ver;
+ SV * rv;
+ STRLEN len = 0;
+ const char * classname = "";
+ U32 flags = 0;
+ if ( items == 2 ) {
+ SV * sv1 = ST(1);
+ SvGETMAGIC(sv1);
+ if (SvOK(sv1)) {
+ ver = sv1;
+ }
+ else {
+ Perl_croak(aTHX_ "Invalid version format (version required)");
+ }
+ 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
+ flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+#endif
+ }
+ else {
+ classname = SvPV(sv0, len);
+ flags = SvUTF8(sv0);
+ }
+ }
+ if ( !SvVOK(ver) ) { /* not already a v-string */
+ rv = sv_newmortal();
+ SvSetSV_nosteal(rv,ver); /* make a duplicate */
+ UPG_VERSION(rv, TRUE);
+ } else {
+ rv = sv_2mortal(NEW_VERSION(ver));
+ }
+ if ( items == 2 && (len != 7
+ || strcmp(classname,"version")) ) { /* inherited new() */
+#if PERL_VERSION == 5
+ sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
+#else
+ sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+#endif
+ }
+ PUSHs(rv);
+ }
+ PUTBACK;
+ return;
+}
+
+
+VXS(version_is_qv)
+{
+ S_version_check_key(aTHX_ cv, "qv", 2);
+}
+
+#endif
@@ -1,3 +1,4 @@
+#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
@@ -11,309 +12,40 @@
typedef SV *version_vxs;
-MODULE = version::vxs PACKAGE = version::vxs
-
-PROTOTYPES: DISABLE
-VERSIONCHECK: DISABLE
-
-BOOT:
- /* register the overloading (type 'A') magic */
- PL_amagic_generation++;
- newXS("version::vxs::()", XS_version__vxs_noop, file);
- newXS("version::vxs::(\"\"", XS_version__vxs_stringify, file);
- newXS("version::vxs::(0+", XS_version__vxs_numify, file);
- newXS("version::vxs::(cmp", XS_version__vxs_VCMP, file);
- newXS("version::vxs::(<=>", XS_version__vxs_VCMP, file);
- newXS("version::vxs::(bool", XS_version__vxs_boolean, file);
- newXS("version::vxs::(+", XS_version__vxs_noop, file);
- newXS("version::vxs::(-", XS_version__vxs_noop, file);
- newXS("version::vxs::(*", XS_version__vxs_noop, file);
- newXS("version::vxs::(/", XS_version__vxs_noop, file);
- newXS("version::vxs::(+=", XS_version__vxs_noop, file);
- newXS("version::vxs::(-=", XS_version__vxs_noop, file);
- newXS("version::vxs::(*=", XS_version__vxs_noop, file);
- newXS("version::vxs::(/=", XS_version__vxs_noop, file);
- newXS("version::vxs::(abs", XS_version__vxs_noop, file);
- newXS("version::vxs::nomethod", XS_version__vxs_noop, file);
+#include "vxs.inc"
-void
-new(...)
-ALIAS:
- parse = 1
-PPCODE:
-{
- SV *vs = ST(1);
- SV *rv;
- const char * classname = "";
- PERL_UNUSED_ARG(ix);
-
- /* Just in case this is something like a tied hash */
- SvGETMAGIC(vs);
-
- if (items > 3 || items == 0)
- Perl_croak(aTHX_ "Usage: version::new(class, version)");
-
- if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
- /* create empty object */
- vs = sv_newmortal();
- sv_setpvs(vs,"undef");
- }
- else if (items == 3 ) {
- vs = sv_newmortal();
- sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
- }
- classname =
- sv_isobject(ST(0)) /* get the class if called as an object method */
- ? HvNAME_get(SvSTASH(SvRV(ST(0))))
- : (char *)SvPV_nolen(ST(0));
-
- rv = NEW_VERSION(vs);
- if ( strcmp(classname,"version::vxs") != 0 ) /* inherited new() */
-#if PERL_VERSION == 5
- sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
-#else
- sv_bless(rv, gv_stashpv(classname, GV_ADD));
+struct xsub_details {
+ const char *name;
+ XSUBADDR_t xsub;
+#ifdef PERL_CORE
+ const char *proto; /* ignored */
#endif
+};
- mPUSHs(rv);
-}
-
-void
-stringify (lobj,...)
- version_vxs lobj
-PPCODE:
-{
- mPUSHs(VSTRINGIFY(lobj));
-}
+static const struct xsub_details details[] = {
+#define VXS_XSUB_DETAILS
+#include "vxs.inc"
+#undef VXS_XSUB_DETAILS
+};
-void
-numify (lobj,...)
- version_vxs lobj
-PPCODE:
-{
- mPUSHs(VNUMIFY(lobj));
-}
-
-void
-normal(ver)
- SV *ver
-PPCODE:
-{
- mPUSHs(VNORMAL(ver));
-}
-
-void
-VCMP (lobj,...)
- version_vxs lobj
-PPCODE:
-{
- SV *rs;
- SV *rvs;
- SV *robj = ST(1);
- const IV swap = (IV)SvIV(ST(2));
-
- if ( ! ISA_CLASS_OBJ(robj, "version::vxs") )
- {
- robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("undef", SVs_TEMP));
- sv_2mortal(robj);
- }
- rvs = SvRV(robj);
-
- if ( swap )
- {
- rs = newSViv(VCMP(rvs,lobj));
- }
- else
- {
- rs = newSViv(VCMP(lobj,rvs));
- }
-
- mPUSHs(rs);
-}
-
-void
-boolean(lobj,...)
- version_vxs lobj
-PPCODE:
-{
- SV * const rs =
- newSViv( VCMP(lobj,
- sv_2mortal(NEW_VERSION(
- sv_2mortal(newSVpvs("0"))
- ))
- )
- );
- mPUSHs(rs);
-}
-
-void
-noop(lobj,...)
- version_vxs lobj
-CODE:
-{
- Perl_croak(aTHX_ "operation not supported with version object");
-}
-
-void
-is_alpha(lobj)
- version_vxs lobj
-PPCODE:
-{
- if ( hv_exists(MUTABLE_HV(lobj), "alpha", 5 ) )
- XSRETURN_YES;
- else
- XSRETURN_NO;
-}
+MODULE = version::vxs PACKAGE = version::vxs
-void
-qv(...)
-ALIAS:
- declare = 1
-PPCODE:
-{
- SV *ver = ST(0);
- SV * rv;
- const char * classname = "";
- PERL_UNUSED_ARG(ix);
+PROTOTYPES: DISABLE
+VERSIONCHECK: DISABLE
- if ( items == 2 ) {
- SvGETMAGIC(ST(1));
- if ( SvOK(ST(1)) ) {
- /* getting called as object or class method */
- ver = ST(1);
- }
- else {
- Perl_croak(aTHX_ "Invalid version format (version required)");
- }
- }
-#ifdef SvVOK
- if ( !SvVOK(ver) ) { /* not already a v-string */
-#endif
- rv = sv_newmortal();
- sv_setsv(rv,ver); /* make a duplicate */
- UPG_VERSION(rv, TRUE);
-#ifdef SvVOK
- }
- else
+BOOT:
{
- rv = sv_2mortal(NEW_VERSION(ver));
- }
-#endif
- classname =
- sv_isobject(ST(0)) /* get the class if called as an object method */
- ? HvNAME_get(SvSTASH(SvRV(ST(0))))
- : (char *)SvPV_nolen(ST(0));
-
- if ( items == 2 && strcmp(classname,"version") ) {
- /* inherited new() */
-#if PERL_VERSION == 5
- sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
+#if (PERL_REVISION == 5 && PERL_VERSION < 9)
+ char* file = __FILE__;
#else
- sv_bless(rv, gv_stashpv(classname, GV_ADD));
+ const char* file = __FILE__;
#endif
+ const struct xsub_details *xsub = details;
+ const struct xsub_details *end
+ = details + sizeof(details) / sizeof(details[0]);
+ /* register the overloading (type 'A') magic */
+ PL_amagic_generation++;
+ do {
+ newXS(xsub->name, xsub->xsub, file);
+ } while (++xsub < end);
}
- PUSHs(rv);
-}
-
-void
-is_qv(lobj)
- version_vxs lobj
-PPCODE:
-{
- if ( hv_exists(MUTABLE_HV(lobj), "qv", 2 ) )
- XSRETURN_YES;
- else
- XSRETURN_NO;
-}
-
-void
-_VERSION(sv,...)
- SV *sv
-PPCODE:
-{
- HV *pkg;
- GV **gvp;
- GV *gv;
- SV *ret;
- const char *undef;
-
- if (SvROK(sv)) {
- sv = (SV*)SvRV(sv);
- if (!SvOBJECT(sv))
- Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
- pkg = SvSTASH(sv);
- }
- else {
- pkg = gv_stashsv(sv, FALSE);
- }
-
- gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : Null(GV**);
-
- if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
- sv = sv_mortalcopy(sv);
- if ( ! ISA_CLASS_OBJ(sv, "version::vxs"))
- UPG_VERSION(sv, FALSE);
- undef = NULL;
- }
- else {
- sv = ret = &PL_sv_undef;
- undef = "(undef)";
- }
-
- if (items > 1) {
- SV *req = ST(1);
-
- if (undef) {
- if (pkg) {
- const char * const name = HvNAME_get(pkg);
-#if PERL_VERSION == 5
- Perl_croak(aTHX_ "%s version %s required--this is only version ",
- name, SvPVx_nolen_const(req));
-#else
- Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
- name, name);
-#endif
- }
- else {
-#if PERL_VERSION >= 8
- Perl_croak(aTHX_ "%s defines neither package nor VERSION--version check failed",
- SvPVx_nolen_const(ST(0)) );
-#else
- Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
- SvPVx_nolen_const(ST(0)),
- SvPVx_nolen_const(ST(0)) );
-#endif
- }
- }
-
- if ( ! ISA_CLASS_OBJ(req, "version")) {
- /* req may very well be R/O, so create a new object */
- req = sv_2mortal( NEW_VERSION(req) );
- }
-
- if ( VCMP( req, sv ) > 0 ) {
- if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
- req = VNORMAL(req);
- sv = VNORMAL(sv);
- }
- else {
- req = VSTRINGIFY(req);
- sv = VSTRINGIFY(sv);
- }
- Perl_croak(aTHX_ "%s version %"SVf" required--"
- "this is only version %"SVf"", HvNAME_get(pkg),
- SVfARG(sv_2mortal(req)),
- 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")) {
- ST(0) = sv_2mortal(VSTRINGIFY(sv));
- } else {
- ST(0) = sv;
- }
-
- XSRETURN(1);
-}