r2158 - in packages/libversion-perl/branches/upstream/current: .
lib lib/version t vperl vutil
Krzysztof Krzyzaniak
eloy at costa.debian.org
Tue Feb 21 15:35:38 UTC 2006
Author: eloy
Date: 2006-02-21 15:35:38 +0000 (Tue, 21 Feb 2006)
New Revision: 2158
Added:
packages/libversion-perl/branches/upstream/current/vperl/
packages/libversion-perl/branches/upstream/current/vperl/vpp.pm
packages/libversion-perl/branches/upstream/current/vutil/vxs.pm
packages/libversion-perl/branches/upstream/current/vutil/vxs.xs
Removed:
packages/libversion-perl/branches/upstream/current/lib/version/vxs.pm
packages/libversion-perl/branches/upstream/current/lib/version/vxs.xs
Modified:
packages/libversion-perl/branches/upstream/current/Build.PL
packages/libversion-perl/branches/upstream/current/Changes
packages/libversion-perl/branches/upstream/current/MANIFEST
packages/libversion-perl/branches/upstream/current/META.yml
packages/libversion-perl/branches/upstream/current/README
packages/libversion-perl/branches/upstream/current/lib/version.pm
packages/libversion-perl/branches/upstream/current/lib/version.pod
packages/libversion-perl/branches/upstream/current/t/coretests.pm
packages/libversion-perl/branches/upstream/current/vutil/vutil.c
Log:
Load /tmp/tmp.By6ecP/libversion-perl-0.56 into
packages/libversion-perl/branches/upstream/current.
Modified: packages/libversion-perl/branches/upstream/current/Build.PL
===================================================================
--- packages/libversion-perl/branches/upstream/current/Build.PL 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/Build.PL 2006-02-21 15:35:38 UTC (rev 2158)
@@ -1,6 +1,53 @@
#!/usr/bin/perl
use Module::Build;
+my $perl_only;
+
+my $t = Module::Build->new(
+ module_name => 'version',
+ get_options => {
+ 'perl_only' => { store => \$perl_only },
+ },
+);
+
+my %build_arguments = (
+ dist_name => 'version',
+ dist_version_from => 'lib/version.pm',
+ license => 'perl',
+ requires => {
+ perl => '> 5.005, !=5.9.1, !=5.9.2',
+ },
+ dynamic_config => 1,
+);
+
+mkdir $t->config_dir();
+
+if ( $perl_only ) { #or not $t->have_c_compiler() ) {
+ $build_arguments{module_name} = 'version::vpp';
+ if ( $] > 5.008001 ) {
+ $build_arguments{requires} = {
+ 'Scalar::Util' => 1.08,
+ };
+ }
+ $build_arguments{pm_files} = {
+ './lib/version.pm' => './lib/version.pm',
+ './vperl/vpp.pm' => 'lib/version/vpp.pm',
+ };
+}
+else {
+ $build_arguments{c_source} = './vutil';
+ $build_arguments{module_name} = 'version::vxs';
+ $build_arguments{pm_files} = {
+ './lib/version.pm' => './lib/version.pm',
+ './vutil/vxs.pm' => 'lib/version/vxs.pm'
+ };
+ $build_arguments{xs_files} = {
+ './vutil/vxs.xs' => 'lib/version/vxs.xs'
+ };
+ $build_arguments{add_to_cleanup} =
+ ['lib/version/vxs.*'];
+}
+
my $class = Module::Build->subclass
(
class => 'version::Builder',
@@ -13,14 +60,6 @@
},
);
-my $m = $class->new(
- module_name => 'version::vxs',
- dist_name => 'version',
- license => 'perl',
- c_source => './vutil',
- requires => {
- 'perl' => '> 5.005, !=5.9.1, !=5.9.2',
- 'Module::Build' => '0.2611',
- },
-);
+my $m = $class->new(%build_arguments);
+
$m->create_build_script;
Modified: packages/libversion-perl/branches/upstream/current/Changes
===================================================================
--- packages/libversion-perl/branches/upstream/current/Changes 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/Changes 2006-02-21 15:35:38 UTC (rev 2158)
@@ -1,3 +1,40 @@
+2006-02-19 John Peacock <jpeacock at cpan.org>
+
+ Another workaround for incomplete testing
+
+2006-02-17 John Peacock <jpeacock at cpan.org>
+
+ Emergency release to fix up M::B 0.2611 problem
+
+2006-02-16 John Peacock <jpeacock at cpan.org>
+
+ Neglected to clean up after XS code (since we are playing games).
+
+2006-02-16 John Peacock <jpeacock at cpan.org>
+
+ No, really, the final changes before releasing to CPAN. :(
+
+2006-02-16 John Peacock <jpeacock at cpan.org>
+
+ Final updates for 0.54 release to CPAN.
+
+2006-02-14 John Peacock <jpeacock at cpan.org>
+
+ Merge from version-combined branch. Equivalent to RELEASE_0_53_03.
+
+2006-02-09 John Peacock <jpeacock at cpan.org>
+
+ Commit changes prior to push to implement pure Perl alternative.
+
+ * Build.PL
+ Need to exclude building on all 5.9.x bleadperl releases.
+
+ * lib/version.pod
+ Forgot a quote in one of the example code fragments.
+
+ * vutil/vutil.c
+ Sync with bleadperl. Only warn if 'use warnings' is set.
+
2006-01-10 John Peacock <jpeacock at cpan.org>
Release 0.53 to CPAN.
Modified: packages/libversion-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libversion-perl/branches/upstream/current/MANIFEST 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/MANIFEST 2006-02-21 15:35:38 UTC (rev 2158)
@@ -3,8 +3,6 @@
lib/version.pm
lib/version.pod
lib/version/typemap
-lib/version/vxs.pm
-lib/version/vxs.xs
Makefile.PL
MANIFEST
META.yml
@@ -12,6 +10,9 @@
t/01base.t
t/02derived.t
t/coretests.pm
+vperl/vpp.pm
vutil/vutil.c
vutil/vutil.h
vutil/ppport.h
+vutil/vxs.pm
+vutil/vxs.xs
Modified: packages/libversion-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libversion-perl/branches/upstream/current/META.yml 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/META.yml 2006-02-21 15:35:38 UTC (rev 2158)
@@ -1,17 +1,17 @@
---
name: version
-version: 0.53
+version: 0.56
author: ~
abstract: ~
license: perl
requires:
- Module::Build: 0.2611
perl: '> 5.005, !=5.9.1, !=5.9.2'
+dynamic_config: 1
provides:
version:
file: lib/version.pm
- version: 0.53
+ version: 0.56
version::vxs:
- file: lib/version/vxs.pm
- version: 0.53
+ file: vutil/vxs.pm
+ version: 0.55
generated_by: Module::Build version 0.2611
Modified: packages/libversion-perl/branches/upstream/current/README
===================================================================
--- packages/libversion-perl/branches/upstream/current/README 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/README 2006-02-21 15:35:38 UTC (rev 2158)
@@ -1,4 +1,4 @@
-version 0.53
+version 0.56
==================================
Provides the same version objects as included in Perl v5.9.x (and hopefully in
@@ -9,40 +9,32 @@
in the core). If you are testing bleadperl, you will need to check out the
latest release of 5.9.x to get the changes included in 0.50.
-Major changes in 0.53
+
+Major changes in 0.56 (was 0.55)
==================================
-The version parsing code always ignored trailing text that couldn't be
-parsed. Now carp about it and show what was ignored. Suggested by David
-Wheeler.
+Nothing at all. This is the second in a series of "not very well tested
+Build.PL" changes. If you want the pure Perl implementation installed you
+must follow the instructions below; the Build.PL file will not do this by
+itself.
-Major changes in 0.52
+Major changes in 0.54
==================================
-Check for malformed initializer ("1_2") based on discussion about
-some bleadperl bugs with vector printing:
+This release includes an optional pure Perl implementation (in case
+you don't have a C-compiler or if some reason you want your code to be
+much slower). You can test it by calling the build script as
- sprintf of version objects
- <https://rt.perl.org/rt3/Ticket/Display.html?id=37897>
+ $ perl Build.PL --perl_only
-Minor changes in 0.51
-==================================
-Continue rewriting the POD as the situation changes with regards to support
-for version objects in various scaffolding programs (CPAN indexer does so
-support version objects).
+and it will install the Perl only version.
-Major changes in 0.50
-==================================
-Completely rewritten POD to hopefully make it clear what is the recommended
-Best Practices (to go along with Damien's book). I also hid the forthcoming
-pure Perl module better (you cannot accidently use it, in other words,
-since it only exists on my hard-drive for now). I also dealt with the
-following bugs:
+NOTE: there is also a significant change in the behavior of the XS module.
+Versions prior to 0.54 mistakenly cloned an existing object, if new()
+was called as an object method. In other words:
- fails tests on AIX 5.1
- <https://rt.cpan.org/Ticket/Display.html?id=15254>
+ $v2 = $v1->new(); # formerly would assign the value of $v1 to $v2
- Missing vpp.pm
- <https://rt.cpan.org/Ticket/Display.html?id=16249>
+This behavior was wrong, and I apologize profusely.
Please read the POD documentation for usage/details. See the CHANGES file
@@ -59,7 +51,7 @@
DEPENDENCIES
-the same C compiler used to build Perl
+The same C compiler used to build Perl (or not).
COPYRIGHT AND LICENCE
Deleted: packages/libversion-perl/branches/upstream/current/lib/version/vxs.pm
===================================================================
--- packages/libversion-perl/branches/upstream/current/lib/version/vxs.pm 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/lib/version/vxs.pm 2006-02-21 15:35:38 UTC (rev 2158)
@@ -1,24 +0,0 @@
-#!perl -w
-package version::vxs;
-
-use 5.005_03;
-use strict;
-
-require Exporter;
-require DynaLoader;
-use vars qw(@ISA $VERSION $CLASS @EXPORT);
-
- at ISA = qw(Exporter DynaLoader);
-
- at EXPORT = qw(qv);
-
-$VERSION = 0.53;
-
-$CLASS = 'version::vxs';
-
-local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
-bootstrap version::vxs if $] < 5.009;
-
-# Preloaded methods go here.
-
-1;
Deleted: packages/libversion-perl/branches/upstream/current/lib/version/vxs.xs
===================================================================
--- packages/libversion-perl/branches/upstream/current/lib/version/vxs.xs 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/lib/version/vxs.xs 2006-02-21 15:35:38 UTC (rev 2158)
@@ -1,257 +0,0 @@
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include "vutil.h"
-
-/* --------------------------------------------------
- * $Revision: 2.5 $
- * --------------------------------------------------*/
-
-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::(nomethod", XS_version__vxs_noop, file);
- newXS("UNIVERSAL::VERSION", XS_version__vxs_VERSION, file);
-
-void
-new(...)
-PPCODE:
-{
- SV *vs = ST(1);
- SV *rv;
- char *class;
-
- /* get the class if called as an object method */
- if ( sv_isobject(ST(0)) ) {
- class = HvNAME(SvSTASH(SvRV(ST(0))));
- }
- else {
- class = (char *)SvPV_nolen(ST(0));
- }
-
- if (items == 3 )
- {
- STRLEN n_a;
- vs = sv_newmortal();
- sv_setpvf(vs,"v%s",SvPV(ST(2),n_a));
- }
- if ( items == 1 )
- {
- /* no parameter provided */
- if ( sv_isobject(ST(0)) )
- {
- /* copy existing object */
- vs = ST(0);
- }
- else
- {
- /* create empty object */
- vs = sv_newmortal();
- sv_setpv(vs,"");
- }
- }
-
- rv = new_version(vs);
- if ( strcmp(class,"version::vxs") != 0 ) /* inherited new() */
- sv_bless(rv, gv_stashpv(class,TRUE));
-
- PUSHs(sv_2mortal(rv));
-}
-
-void
-stringify (lobj,...)
- version_vxs lobj
-PPCODE:
-{
- PUSHs(sv_2mortal(vstringify(lobj)));
-}
-
-void
-numify (lobj,...)
- version_vxs lobj
-PPCODE:
-{
- PUSHs(sv_2mortal(vnumify(lobj)));
-}
-
-void
-vcmp (lobj,...)
- version_vxs lobj
-PPCODE:
-{
- SV *rs;
- SV * robj = ST(1);
- IV swap = (IV)SvIV(ST(2));
-
- if ( ! sv_derived_from(robj, "version::vxs") )
- {
- robj = sv_2mortal(new_version(robj));
- }
-
- if ( swap )
- {
- rs = newSViv(vcmp(robj,lobj));
- }
- else
- {
- rs = newSViv(vcmp(lobj,robj));
- }
-
- PUSHs(sv_2mortal(rs));
-}
-
-void
-boolean(lobj,...)
- version_vxs lobj
-PPCODE:
-{
- SV *rs;
- rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
- PUSHs(sv_2mortal(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((HV*)SvRV(lobj), "alpha", 5 ) )
- XSRETURN_YES;
- else
- XSRETURN_NO;
-}
-
-void
-qv(ver)
- SV *ver
-PPCODE:
-{
-#ifdef SvVOK
- if ( !SvVOK(ver) ) { /* not already a v-string */
-#endif
- SV *vs = sv_newmortal();
- char *version;
- if ( SvNOK(ver) ) /* may get too much accuracy */
- {
- char tbuf[64];
- sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
- version = savepv(tbuf);
- }
- else
- {
- STRLEN n_a;
- version = savepv(SvPV(ver,n_a));
- }
- (void)scan_version(version,vs,TRUE);
- Safefree(version);
-
- PUSHs(vs);
-#ifdef SvVOK
- }
- else
- {
- PUSHs(sv_2mortal(new_version(ver)));
- }
-#endif
-}
-
-void
-normal(ver)
- SV *ver
-PPCODE:
-{
- PUSHs(sv_2mortal(vnormal(ver)));
-}
-
-void
-VERSION(sv,...)
- SV *sv
-PPCODE:
-{
- HV *pkg;
- GV **gvp;
- GV *gv;
- 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_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
-
- if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
- SV *nsv = sv_newmortal();
- sv_setsv(nsv, sv);
- sv = nsv;
- if ( !sv_derived_from(sv, "version::vxs"))
- upg_version(sv);
- undef = Nullch;
- }
- else {
- sv = (SV*)&PL_sv_undef;
- undef = "(undef)";
- }
-
- if (items > 1) {
- SV *req = ST(1);
- STRLEN len;
-
- if (undef) {
- if (pkg)
- Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
- HvNAME(pkg), HvNAME(pkg));
- else {
- char *str = SvPVx(ST(0), len);
-
- Perl_croak(aTHX_ "%s defines neither package nor VERSION--version check failed", str);
- }
- }
-
- if ( !sv_derived_from(req, "version::vxs")) {
- /* req may very well be R/O, so create a new object */
- SV *nsv = sv_newmortal();
- sv_setsv(nsv, req);
- req = nsv;
- upg_version(req);
- }
-
- if ( vcmp( req, sv ) > 0 )
- Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
- "this is only version %"SVf" (%"SVf")", HvNAME(pkg),
- vnumify(req),vnormal(req),vnumify(sv),vnormal(sv));
- }
-
- if ( SvOK(sv) && sv_derived_from(sv, "version::vxs") )
- PUSHs(vnumify(sv));
- else
- PUSHs(sv);
-
- XSRETURN(1);
-}
Modified: packages/libversion-perl/branches/upstream/current/lib/version.pm
===================================================================
--- packages/libversion-perl/branches/upstream/current/lib/version.pm 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/lib/version.pm 2006-02-21 15:35:38 UTC (rev 2158)
@@ -11,18 +11,18 @@
@EXPORT = qw(qv);
-$VERSION = 0.53;
+$VERSION = 0.56;
$CLASS = 'version';
-eval { require version::vxs; };
+eval "use version::vxs $VERSION";
if ( $@ ) # don't have the XS version installed
{
-# eval { require version::vpp }; # don't tempt fate
+ eval "use version::vpp $VERSION"; # don't tempt fate
die "$@" if ( $@ );
-# push @ISA, "version::PP";
-# *qv = \&version::vpp::qv;
+ push @ISA, "version::vpp";
+ *qv = \&version::vpp::qv;
}
else # use XS module
{
Modified: packages/libversion-perl/branches/upstream/current/lib/version.pod
===================================================================
--- packages/libversion-perl/branches/upstream/current/lib/version.pod 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/lib/version.pod 2006-02-21 15:35:38 UTC (rev 2158)
@@ -110,7 +110,7 @@
$v = version->new(1.002); # 1.002, but compares like 1.2.0
$v = version->new(1.002003); # 1.002003
- $v2 = version->new( "1.2.3"); # v1.2.3
+ $v2 = version->new("1.2.3"); # v1.2.3
In specific, version numbers initialized as L<Numeric Versions> will
stringify in Numeric form. Version numbers initialized as L<Extended Versions>
@@ -161,7 +161,7 @@
# Prints
$v = version->new( "v1.200"); # v1.200.0
$v = version->new("v1.20.0"); # v1.20.0
- $v = qv("v1.2.3); # v1.2.3
+ $v = qv("v1.2.3"); # v1.2.3
$v = qv("1.2.3"); # v1.2.3
$v = qv("1.20"); # v1.20.0
@@ -236,9 +236,15 @@
or as an object method:
$v1 = version->new(12.3);
+ $v2 = $v1->new(12.3);
+
+and in each case, $v1 and $v2 will be identical. NOTE: if you create
+a new object using an existing object like this:
+
$v2 = $v1->new();
-and in each case, $v1 and $v2 will be identical.
+the new object B<will not> be a clone of the existing object. In the
+example case, $v2 will be an empty object of the same type as $v1.
=back
Modified: packages/libversion-perl/branches/upstream/current/t/coretests.pm
===================================================================
--- packages/libversion-perl/branches/upstream/current/t/coretests.pm 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/t/coretests.pm 2006-02-21 15:35:38 UTC (rev 2158)
@@ -213,7 +213,8 @@
"new from existing object");
ok ($new_version == $version, "class->new($version) identical");
$new_version = $version->new();
- ok ($new_version == $version, "$version->new() also identical");
+ isa_ok ($new_version, $CLASS );
+ is ($new_version, "0.000", "version->new() doesn't clone");
$new_version = $version->new("1.2.3");
is ($new_version, "v1.2.3" , '$version->new("1.2.3") works too');
Added: packages/libversion-perl/branches/upstream/current/vperl/vpp.pm
===================================================================
--- packages/libversion-perl/branches/upstream/current/vperl/vpp.pm 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/vperl/vpp.pm 2006-02-21 15:35:38 UTC (rev 2158)
@@ -0,0 +1,390 @@
+
+package version::vpp;
+use strict;
+
+use Exporter ();
+use Scalar::Util qw(isvstring reftype);
+use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS @REGEXS);
+$VERSION = $version::VERSION;
+ at ISA = qw (Exporter);
+#Give a hoot don't pollute, do not export more than needed by default
+ at EXPORT = qw (qv);
+ at EXPORT_OK = qw ();
+%EXPORT_TAGS = ();
+
+push @REGEXS, qr/
+ ^v? # optional leading 'v'
+ (\d*) # major revision not required
+ \. # requires at least one decimal
+ (?:(\d+)\.?){1,}
+ /x;
+
+local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
+
+use overload (
+ '+0' => \&numify,
+ '""' => \&stringify,
+ 'cmp' => \&vcmp,
+ '<=>' => \&vcmp,
+);
+
+sub new
+{
+ my ($class, $value) = @_;
+ my $self = bless ({}, ref ($class) || $class);
+
+ if ( $#_ == 2 ) { # must be CVS-style
+ $value = 'v'.$_[2];
+ }
+
+ if ( isvstring($value) ) {
+ $value = sprintf("v%vd",$value);
+ }
+
+ # This is not very efficient, but it is morally equivalent
+ # to the XS code (as that is the reference implementation).
+ # See vutil/vutil.c for details
+ my $qv = 0;
+ my $alpha = 0;
+ my $width = 3;
+ my $saw_period = 0;
+ my ($start, $last, $pos, $s);
+ $s = 0;
+
+ while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
+ $s++;
+ }
+
+ if (substr($value,$s,1) eq 'v') {
+ $s++; # get past 'v'
+ $qv = 1; # force quoted version processing
+ }
+
+ $start = $last = $pos = $s;
+
+ # pre-scan the input string to check for decimals/underbars
+ while ( substr($value,$pos,1) =~ /[._\d]/ ) {
+ if ( substr($value,$pos,1) eq '.' ) {
+ die "Invalid version format (underscores before decimal)"
+ if $alpha;
+ $saw_period++;
+ $last = $pos;
+ }
+ elsif ( substr($value,$pos,1) eq '_' ) {
+ die "Invalid version format (multiple underscores)"
+ if $alpha;
+ $alpha = 1;
+ $width = $pos - $last - 1; # natural width of sub-version
+ }
+ $pos++;
+ }
+
+ if ( $alpha && !$saw_period ) {
+ die "Invalid version format (alpha without decimal)";
+ }
+
+ if ( $saw_period > 1 ) {
+ $qv = 1; # force quoted version processing
+ }
+
+ $pos = $s;
+
+ if ( $qv ) {
+ $self->{qv} = 1;
+ }
+
+ if ( $alpha ) {
+ $self->{alpha} = 1;
+ }
+
+ if ( !$qv && $width < 3 ) {
+ $self->{width} = $width;
+ }
+
+ while ( substr($value,$pos,1) =~ /\d/ ) {
+ $pos++;
+ }
+
+ if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
+ my $rev;
+
+ while (1) {
+ $rev = 0;
+ {
+
+ # this is atoi() that delimits on underscores
+ my $end = $pos;
+ my $mult = 1;
+ my $orev;
+
+ # the following if() will only be true after the decimal
+ # point of a version originally created with a bare
+ # floating point number, i.e. not quoted in any way
+ if ( !$qv && $s > $start && $saw_period == 1 ) {
+ $mult *= 100;
+ while ( $s < $end ) {
+ $orev = $rev;
+ $rev += substr($value,$s,1) * $mult;
+ $mult /= 10;
+ if ( abs($orev) > abs($rev) ) {
+ die "Integer overflow in version";
+ }
+ $s++;
+ if ( substr($value,$s,1) eq '_' ) {
+ $s++;
+ }
+ }
+ }
+ else {
+ while (--$end >= $s) {
+ $orev = $rev;
+ $rev += substr($value,$end,1) * $mult;
+ $mult *= 10;
+ if ( abs($orev) > abs($rev) ) {
+ die "Integer overflow in version";
+ }
+ }
+ }
+ }
+
+ # Append revision
+ push @{$self->{version}}, $rev;
+ if ( substr($value,$pos,1) eq '.'
+ && substr($value,$pos+1,1) =~ /\d/ ) {
+ $s = ++$pos;
+ }
+ elsif ( substr($value,$pos,1) eq '_'
+ && substr($value,$pos+1,1) =~ /\d/ ) {
+ $s = ++$pos;
+ }
+ elsif ( substr($value,$pos,1) =~ /\d/ ) {
+ $s = $pos;
+ }
+ else {
+ $s = $pos;
+ last;
+ }
+ if ( $qv ) {
+ while ( substr($value,$pos,1) =~ /\d/ ) {
+ $pos++;
+ }
+ }
+ else {
+ my $digits = 0;
+ while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
+ if ( substr($value,$pos,1) ne '_' ) {
+ $digits++;
+ }
+ $pos++;
+ }
+ }
+ }
+ }
+ if ( $qv ) { # quoted versions always get at least three terms
+ my $len = scalar @{$self->{version}};
+ $len = 3 - $len;
+ while ($len-- > 0) {
+ push @{$self->{version}}, 0;
+ }
+ }
+
+ if ( not exists $self->{version} ) {
+ # oops, someone forgot to pass a value (shouldn't happen)
+ push @{$self->{version}}, 0;
+ }
+
+ if ( substr($value,$pos) ) { # any remaining text
+ warn "Version string '$value' contains invalid data; ".
+ "ignoring: '".substr($value,$pos)."'";
+ }
+
+ return ($self);
+}
+
+sub numify
+{
+ my ($self) = @_;
+ unless (_verify($self)) {
+ die "Invalid version object";
+ }
+ my $width = $self->{width} || 3;
+ my $alpha = $self->{alpha} || "";
+ my $len = $#{$self->{version}};
+ my $digit = $self->{version}[0];
+ my $string = sprintf("%d.", $digit );
+
+ for ( my $i = 1 ; $i < $len ; $i++ ) {
+ $digit = $self->{version}[$i];
+ if ( $width < 3 ) {
+ my $denom = 10**(3-$width);
+ my $quot = int($digit/$denom);
+ my $rem = $digit - ($quot * $denom);
+ $string .= sprintf("%0".$width."d_%d", $quot, $rem);
+ }
+ else {
+ $string .= sprintf("%03d", $digit);
+ }
+ }
+
+ if ( $len > 0 ) {
+ $digit = $self->{version}[$len];
+ if ( $alpha && $width == 3 ) {
+ $string .= "_";
+ }
+ $string .= sprintf("%0".$width."d", $digit);
+ }
+ else # $len = 0
+ {
+ $string .= sprintf("000");
+ }
+
+ return $string;
+}
+
+sub normal
+{
+ my ($self) = @_;
+ unless (_verify($self)) {
+ die "Invalid version object";
+ }
+ my $alpha = $self->{alpha} || "";
+ my $len = $#{$self->{version}};
+ my $digit = $self->{version}[0];
+ my $string = sprintf("v%d", $digit );
+
+ for ( my $i = 1 ; $i < $len ; $i++ ) {
+ $digit = $self->{version}[$i];
+ $string .= sprintf(".%d", $digit);
+ }
+
+ if ( $len > 0 ) {
+ $digit = $self->{version}[$len];
+ if ( $alpha ) {
+ $string .= sprintf("_%0d", $digit);
+ }
+ else {
+ $string .= sprintf(".%0d", $digit);
+ }
+ }
+
+ if ( $len <= 2 ) {
+ for ( $len = 2 - $len; $len != 0; $len-- ) {
+ $string .= sprintf(".%0d", 0);
+ }
+ }
+
+ return $string;
+}
+
+sub stringify
+{
+ my ($self) = @_;
+ unless (_verify($self)) {
+ die "Invalid version object";
+ }
+ if ( exists $self->{qv} ) {
+ return $self->normal;
+ }
+ else {
+ return $self->numify;
+ }
+}
+
+sub vcmp
+{
+ require UNIVERSAL;
+ my ($left,$right,$swap) = @_;
+ my $class = ref($left);
+ unless ( UNIVERSAL::isa($right, $class) ) {
+ $right = $class->new($right);
+ }
+
+ if ( $swap ) {
+ ($left, $right) = ($right, $left);
+ }
+ unless (_verify($left)) {
+ die "Invalid version object";
+ }
+ unless (_verify($right)) {
+ die "Invalid version object";
+ }
+ my $l = $#{$left->{version}};
+ my $r = $#{$right->{version}};
+ my $m = $l < $r ? $l : $r;
+ my $lalpha = $left->is_alpha;
+ my $ralpha = $right->is_alpha;
+ my $retval = 0;
+ my $i = 0;
+ while ( $i <= $m && $retval == 0 ) {
+ $retval = $left->{version}[$i] <=> $right->{version}[$i];
+ $i++;
+ }
+
+ # tiebreaker for alpha with identical terms
+ if ( $retval == 0
+ && $l == $r
+ && $left->{version}[$m] == $right->{version}[$m]
+ && ( $lalpha || $ralpha ) ) {
+
+ if ( $lalpha && !$ralpha ) {
+ $retval = -1;
+ }
+ elsif ( $ralpha && !$lalpha) {
+ $retval = +1;
+ }
+ }
+
+ # possible match except for trailing 0's
+ if ( $retval == 0 && $l != $r ) {
+ if ( $l < $r ) {
+ while ( $i <= $r && $retval == 0 ) {
+ if ( $right->{version}[$i] != 0 ) {
+ $retval = -1; # not a match after all
+ }
+ $i++;
+ }
+ }
+ else {
+ while ( $i <= $l && $retval == 0 ) {
+ if ( $left->{version}[$i] != 0 ) {
+ $retval = +1; # not a match after all
+ }
+ $i++;
+ }
+ }
+ }
+
+ return $retval;
+}
+
+sub is_alpha {
+ my ($self) = @_;
+ return (exists $self->{alpha});
+}
+
+sub qv {
+ my ($value) = @_;
+
+ if ( isvstring($value) ) {
+ $value = sprintf("v%vd",$value);
+ }
+ else {
+ $value = 'v'.$value unless $value =~ /^v/;
+ }
+ return version->new($value); # always use base class
+}
+
+sub _verify {
+ my ($self) = @_;
+ if ( reftype($self) eq 'HASH'
+ && exists $self->{version}
+ && ref($self->{version}) eq 'ARRAY'
+ ) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+1; #this line is important and will help the module return a true value
Modified: packages/libversion-perl/branches/upstream/current/vutil/vutil.c
===================================================================
--- packages/libversion-perl/branches/upstream/current/vutil/vutil.c 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/vutil/vutil.c 2006-02-21 15:35:38 UTC (rev 2158)
@@ -284,7 +284,9 @@
}
s = scan_version(version, ver, qv);
if ( *s != '\0' )
- warn( "Version string '%s' contains invalid data; "
+ if(ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Version string '%s' contains invalid data; "
"ignoring: '%s'", version, s);
Safefree(version);
return ver;
Added: packages/libversion-perl/branches/upstream/current/vutil/vxs.pm
===================================================================
--- packages/libversion-perl/branches/upstream/current/vutil/vxs.pm 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/vutil/vxs.pm 2006-02-21 15:35:38 UTC (rev 2158)
@@ -0,0 +1,24 @@
+#!perl -w
+package version::vxs;
+
+use 5.005_03;
+use strict;
+
+require Exporter;
+require DynaLoader;
+use vars qw(@ISA $VERSION $CLASS @EXPORT);
+
+ at ISA = qw(Exporter DynaLoader);
+
+ at EXPORT = qw(qv);
+
+$VERSION = $version::VERSION;
+
+$CLASS = 'version::vxs';
+
+local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
+bootstrap version::vxs if $] < 5.009;
+
+# Preloaded methods go here.
+
+1;
Added: packages/libversion-perl/branches/upstream/current/vutil/vxs.xs
===================================================================
--- packages/libversion-perl/branches/upstream/current/vutil/vxs.xs 2006-02-21 15:31:36 UTC (rev 2157)
+++ packages/libversion-perl/branches/upstream/current/vutil/vxs.xs 2006-02-21 15:35:38 UTC (rev 2158)
@@ -0,0 +1,252 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "vutil.h"
+
+/* --------------------------------------------------
+ * $Revision: 2.5 $
+ * --------------------------------------------------*/
+
+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::(nomethod", XS_version__vxs_noop, file);
+ newXS("UNIVERSAL::VERSION", XS_version__vxs_VERSION, file);
+
+void
+new(...)
+PPCODE:
+{
+ SV *vs = ST(1);
+ SV *rv;
+ char *class;
+
+ /* get the class if called as an object method */
+ if ( sv_isobject(ST(0)) ) {
+ class = HvNAME(SvSTASH(SvRV(ST(0))));
+ }
+ else {
+ class = (char *)SvPV_nolen(ST(0));
+ }
+
+ if (items == 3 )
+ {
+ STRLEN n_a;
+ vs = sv_newmortal();
+ sv_setpvf(vs,"v%s",SvPV(ST(2),n_a));
+ }
+ if ( items == 1 )
+ {
+ /* no parameter provided */
+ if ( sv_isobject(ST(0)) )
+ {
+ /* create empty object */
+ vs = sv_newmortal();
+ sv_setpv(vs,"");
+ }
+ }
+
+ rv = new_version(vs);
+ if ( strcmp(class,"version::vxs") != 0 ) /* inherited new() */
+ sv_bless(rv, gv_stashpv(class,TRUE));
+
+ PUSHs(sv_2mortal(rv));
+}
+
+void
+stringify (lobj,...)
+ version_vxs lobj
+PPCODE:
+{
+ PUSHs(sv_2mortal(vstringify(lobj)));
+}
+
+void
+numify (lobj,...)
+ version_vxs lobj
+PPCODE:
+{
+ PUSHs(sv_2mortal(vnumify(lobj)));
+}
+
+void
+vcmp (lobj,...)
+ version_vxs lobj
+PPCODE:
+{
+ SV *rs;
+ SV * robj = ST(1);
+ IV swap = (IV)SvIV(ST(2));
+
+ if ( ! sv_derived_from(robj, "version::vxs") )
+ {
+ robj = sv_2mortal(new_version(robj));
+ }
+
+ if ( swap )
+ {
+ rs = newSViv(vcmp(robj,lobj));
+ }
+ else
+ {
+ rs = newSViv(vcmp(lobj,robj));
+ }
+
+ PUSHs(sv_2mortal(rs));
+}
+
+void
+boolean(lobj,...)
+ version_vxs lobj
+PPCODE:
+{
+ SV *rs;
+ rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
+ PUSHs(sv_2mortal(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((HV*)SvRV(lobj), "alpha", 5 ) )
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+}
+
+void
+qv(ver)
+ SV *ver
+PPCODE:
+{
+#ifdef SvVOK
+ if ( !SvVOK(ver) ) { /* not already a v-string */
+#endif
+ SV *vs = sv_newmortal();
+ char *version;
+ if ( SvNOK(ver) ) /* may get too much accuracy */
+ {
+ char tbuf[64];
+ sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+ version = savepv(tbuf);
+ }
+ else
+ {
+ STRLEN n_a;
+ version = savepv(SvPV(ver,n_a));
+ }
+ (void)scan_version(version,vs,TRUE);
+ Safefree(version);
+
+ PUSHs(vs);
+#ifdef SvVOK
+ }
+ else
+ {
+ PUSHs(sv_2mortal(new_version(ver)));
+ }
+#endif
+}
+
+void
+normal(ver)
+ SV *ver
+PPCODE:
+{
+ PUSHs(sv_2mortal(vnormal(ver)));
+}
+
+void
+VERSION(sv,...)
+ SV *sv
+PPCODE:
+{
+ HV *pkg;
+ GV **gvp;
+ GV *gv;
+ 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_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
+
+ if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
+ SV *nsv = sv_newmortal();
+ sv_setsv(nsv, sv);
+ sv = nsv;
+ if ( !sv_derived_from(sv, "version::vxs"))
+ upg_version(sv);
+ undef = Nullch;
+ }
+ else {
+ sv = (SV*)&PL_sv_undef;
+ undef = "(undef)";
+ }
+
+ if (items > 1) {
+ SV *req = ST(1);
+ STRLEN len;
+
+ if (undef) {
+ if (pkg)
+ Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
+ HvNAME(pkg), HvNAME(pkg));
+ else {
+ char *str = SvPVx(ST(0), len);
+
+ Perl_croak(aTHX_ "%s defines neither package nor VERSION--version check failed", str);
+ }
+ }
+
+ if ( !sv_derived_from(req, "version::vxs")) {
+ /* req may very well be R/O, so create a new object */
+ SV *nsv = sv_newmortal();
+ sv_setsv(nsv, req);
+ req = nsv;
+ upg_version(req);
+ }
+
+ if ( vcmp( req, sv ) > 0 )
+ Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
+ "this is only version %"SVf" (%"SVf")", HvNAME(pkg),
+ vnumify(req),vnormal(req),vnumify(sv),vnormal(sv));
+ }
+
+ if ( SvOK(sv) && sv_derived_from(sv, "version::vxs") )
+ PUSHs(vnumify(sv));
+ else
+ PUSHs(sv);
+
+ XSRETURN(1);
+}
More information about the Pkg-perl-cvs-commits
mailing list