summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFather Chrysostomos <sprout@cpan.org>2014-01-04 05:15:32 -0800
committerFather Chrysostomos <sprout@cpan.org>2014-01-04 05:15:32 -0800
commita76c354d5bbd0beffab91da21869cc5a9ef5ee30 (patch)
tree7f47130974a538532b825c355647c12cc5326f3a
parent99eb9e74c5621c98b79fad6a6c6d707d5741fbec (diff)
parentc950d3bdada3085d6065466a3a8526d17b1fc779 (diff)
downloadperl-a76c354d5bbd0beffab91da21869cc5a9ef5ee30.tar.gz
[Merge] [rt.cpan.org #88458] version XS routine revamp
This branch moves the version-specific XS and C functions in universal.c and util.c into two new files, #included by the former. This is to make it easier to keep core and CPAN in synch. Up till now, changes made to one had to be manually applied to the other (except that was not actually happening all the time, so they got out of synch). A corresponding CPAN release has yet to be made.
-rw-r--r--MANIFEST9
-rwxr-xr-xPorting/Maintainers.pl12
-rw-r--r--cpan/version/lib/version.pm135
-rw-r--r--cpan/version/lib/version/regex.pm117
-rw-r--r--cpan/version/lib/version/vpp.pm1021
-rw-r--r--cpan/version/t/00impl-pp.t18
-rw-r--r--cpan/version/t/01base.t2
-rw-r--r--cpan/version/t/02derived.t8
-rw-r--r--cpan/version/t/03require.t2
-rw-r--r--cpan/version/t/05sigdie.t2
-rw-r--r--cpan/version/t/06noop.t2
-rw-r--r--cpan/version/t/07locale.t9
-rw-r--r--cpan/version/t/08_corelist.t12
-rw-r--r--cpan/version/t/09_list_util.t37
-rw-r--r--cpan/version/t/coretests.pm25
-rw-r--r--t/porting/customized.dat6
-rw-r--r--universal.c411
-rw-r--r--util.c940
-rw-r--r--vutil.c1009
-rw-r--r--vutil.h179
-rw-r--r--vxs.inc458
21 files changed, 2926 insertions, 1488 deletions
diff --git a/MANIFEST b/MANIFEST
index a0a85783fe..9acf1688ef 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2742,7 +2742,10 @@ cpan/Unicode-Normalize/t/tie.t Unicode::Normalize
cpan/version/lib/version/Internals.pod Description of the internals of version objects
cpan/version/lib/version.pm Support for version objects
cpan/version/lib/version.pod Documentation of the version module
-cpan/version/t/01base.t Tests for version objects`
+cpan/version/lib/version/regex.pm Regex for matching version objects
+cpan/version/lib/version/vpp.pm Pure Perl implementation of XS code
+cpan/version/t/00impl-pp.t Tests for version objects
+cpan/version/t/01base.t Tests for version objects
cpan/version/t/02derived.t Tests for version objects
cpan/version/t/03require.t Tests for version objects
cpan/version/t/04strict_lax.t Tests for version objects
@@ -2750,6 +2753,7 @@ cpan/version/t/05sigdie.t Tests for version objects
cpan/version/t/06noop.t Tests for version objects
cpan/version/t/07locale.t Tests for version objects
cpan/version/t/08_corelist.t Tests for version objects
+cpan/version/t/09_list_util.t Tests for version objects
cpan/version/t/coretests.pm Tests for version objects
cpan/Win32API-File/buffers.h Win32API::File extension
cpan/Win32API-File/cFile.h Win32API::File extension
@@ -5478,6 +5482,9 @@ vos/configure_full_perl.sh VOS shell script to configure "full" perl before buil
vos/make_full_perl.sh VOS shell script to build and test "full" perl
vos/vos.c VOS emulations for missing POSIX functions
vos/vosish.h VOS-specific header file
+vutil.c Version object C functions
+vutil.h Version object headers
+vxs.inc Version object XS methods
warnings.h The warning numbers
win32/bin/exetype.pl Set executable type to CONSOLE or WINDOWS
win32/bin/perlglob.pl Win32 globbing
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 466d6a8772..bacb206d44 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -1262,7 +1262,9 @@ use File::Glob qw(:case);
'DISTRIBUTION' => 'JPEACOCK/version-0.9904.tar.gz',
'FILES' => q[cpan/version],
'EXCLUDED' => [
- qr{^vutil/},
+ qr{^vutil/lib/},
+ 'vutil/ppport.h',
+ 'vutil/vxs.xs',
'lib/version/typemap',
't/survey_locales',
'vperl/vpp.pm',
@@ -1276,8 +1278,12 @@ use File::Glob qw(:case);
),
],
- # Remove this (so it reverts to 'cpan') when [cpan #88458] is resolved
- 'UPSTREAM' => 'blead',
+ 'MAP' => {
+ 'vutil.c' => 'vutil.c',
+ 'vutil.h' => 'vutil.h',
+ 'vxs.inc' => 'vxs.inc',
+ '' => 'cpan/version/',
+ },
},
'warnings' => {
diff --git a/cpan/version/lib/version.pm b/cpan/version/lib/version.pm
index 1e86ac23c1..b21f1bdf56 100644
--- a/cpan/version/lib/version.pm
+++ b/cpan/version/lib/version.pm
@@ -1,129 +1,28 @@
#!perl -w
package version;
-use 5.005_04;
+use 5.005_05;
use strict;
-use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-
-$VERSION = 0.9904;
+use vars qw(@ISA $VERSION $CLASS *declare *qv);
+$VERSION = 0.9905;
$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;
+# avoid using Exporter
+require version::regex;
+*version::is_lax = \&version::regex::is_lax;
+*version::is_strict = \&version::regex::is_strict;
-# 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 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;
@@ -152,22 +51,26 @@ sub import {
unless defined(&{$callpkg.'::qv'});
}
+ if (exists($args{'UNIVERSAL::VERSION'})) {
+ local $^W;
+ *UNIVERSAL::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;
diff --git a/cpan/version/lib/version/regex.pm b/cpan/version/lib/version/regex.pm
new file mode 100644
index 0000000000..7370b5b04c
--- /dev/null
+++ b/cpan/version/lib/version/regex.pm
@@ -0,0 +1,117 @@
+package version::regex;
+
+use strict;
+
+use vars qw($VERSION $CLASS $STRICT $LAX);
+
+$VERSION = 0.9905;
+
+#--------------------------------------------------------------------------#
+# 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;
diff --git a/cpan/version/lib/version/vpp.pm b/cpan/version/lib/version/vpp.pm
new file mode 100644
index 0000000000..c879c398c8
--- /dev/null
+++ b/cpan/version/lib/version/vpp.pm
@@ -0,0 +1,1021 @@
+package charstar;
+# a little helper class to emulate C char* semantics in Perl
+# so that prescan_version can use the same code as in C
+
+use overload (
+ '""' => \&thischar,
+ '0+' => \&thischar,
+ '++' => \&increment,
+ '--' => \&decrement,
+ '+' => \&plus,
+ '-' => \&minus,
+ '*' => \&multiply,
+ 'cmp' => \&cmp,
+ '<=>' => \&spaceship,
+ 'bool' => \&thischar,
+ '=' => \&clone,
+);
+
+sub new {
+ my ($self, $string) = @_;
+ my $class = ref($self) || $self;
+
+ my $obj = {
+ string => [split(//,$string)],
+ current => 0,
+ };
+ return bless $obj, $class;
+}
+
+sub thischar {
+ my ($self) = @_;
+ my $last = $#{$self->{string}};
+ my $curr = $self->{current};
+ if ($curr >= 0 && $curr <= $last) {
+ return $self->{string}->[$curr];
+ }
+ else {
+ return '';
+ }
+}
+
+sub increment {
+ my ($self) = @_;
+ $self->{current}++;
+}
+
+sub decrement {
+ my ($self) = @_;
+ $self->{current}--;
+}
+
+sub plus {
+ my ($self, $offset) = @_;
+ my $rself = $self->clone;
+ $rself->{current} += $offset;
+ return $rself;
+}
+
+sub minus {
+ my ($self, $offset) = @_;
+ my $rself = $self->clone;
+ $rself->{current} -= $offset;
+ return $rself;
+}
+
+sub multiply {
+ my ($left, $right, $swapped) = @_;
+ my $char = $left->thischar();
+ return $char * $right;
+}
+
+sub spaceship {
+ my ($left, $right, $swapped) = @_;
+ unless (ref($right)) { # not an object already
+ $right = $left->new($right);
+ }
+ return $left->{current} <=> $right->{current};
+}
+
+sub cmp {
+ my ($left, $right, $swapped) = @_;
+ unless (ref($right)) { # not an object already
+ if (length($right) == 1) { # comparing single character only
+ return $left->thischar cmp $right;
+ }
+ $right = $left->new($right);
+ }
+ return $left->currstr cmp $right->currstr;
+}
+
+sub bool {
+ my ($self) = @_;
+ my $char = $self->thischar;
+ return ($char ne '');
+}
+
+sub clone {
+ my ($left, $right, $swapped) = @_;
+ $right = {
+ string => [@{$left->{string}}],
+ current => $left->{current},
+ };
+ return bless $right, ref($left);
+}
+
+sub currstr {
+ my ($self, $s) = @_;
+ my $curr = $self->{current};
+ my $last = $#{$self->{string}};
+ if (defined($s) && $s->{current} < $last) {
+ $last = $s->{current};
+ }
+
+ my $string = join('', @{$self->{string}}[$curr..$last]);
+ return $string;
+}
+
+package version::vpp;
+
+use 5.005_05;
+use strict;
+
+use POSIX qw/locale_h/;
+use locale;
+use vars qw($VERSION $CLASS @ISA);
+$VERSION = 0.9905;
+$CLASS = 'version::vpp';
+
+require version::regex;
+*version::vpp::is_strict = \&version::regex::is_strict;
+*version::vpp::is_lax = \&version::regex::is_lax;
+
+use overload (
+ '""' => \&stringify,
+ '0+' => \&numify,
+ 'cmp' => \&vcmp,
+ '<=>' => \&vcmp,
+ 'bool' => \&vbool,
+ '+' => \&vnoop,
+ '-' => \&vnoop,
+ '*' => \&vnoop,
+ '/' => \&vnoop,
+ '+=' => \&vnoop,
+ '-=' => \&vnoop,
+ '*=' => \&vnoop,
+ '/=' => \&vnoop,
+ 'abs' => \&vnoop,
+);
+
+eval "use warnings";
+if ($@) {
+ eval '
+ package
+ warnings;
+ sub enabled {return $^W;}
+ 1;
+ ';
+}
+
+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
+use constant TRUE => 1;
+use constant FALSE => 0;
+
+sub isDIGIT {
+ my ($char) = shift->thischar();
+ return ($char =~ /\d/);
+}
+
+sub isALPHA {
+ my ($char) = shift->thischar();
+ return ($char =~ /[a-zA-Z]/);
+}
+
+sub isSPACE {
+ my ($char) = shift->thischar();
+ return ($char =~ /\s/);
+}
+
+sub BADVERSION {
+ my ($s, $errstr, $error) = @_;
+ if ($errstr) {
+ $$errstr = $error;
+ }
+ return $s;
+}
+
+sub prescan_version {
+ my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
+ my $qv = defined $sqv ? $$sqv : FALSE;
+ my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
+ my $width = defined $swidth ? $$swidth : 3;
+ my $alpha = defined $salpha ? $$salpha : FALSE;
+
+ my $d = $s;
+
+ if ($qv && isDIGIT($d)) {
+ goto dotted_decimal_version;
+ }
+
+ if ($d eq 'v') { # explicit v-string
+ $d++;
+ if (isDIGIT($d)) {
+ $qv = TRUE;
+ }
+ else { # degenerate v-string
+ # requires v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if ($strict && $d eq '0' && isDIGIT($d+1)) {
+ # no leading zeros allowed
+ return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT($d)) { # integer part
+ $d++;
+ }
+
+ if ($d eq '.')
+ {
+ $saw_decimal++;
+ $d++; # decimal point
+ }
+ else
+ {
+ if ($strict) {
+ # require v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ my $i = 0;
+ my $j = 0;
+ while (isDIGIT($d)) { # just keep reading
+ $i++;
+ while (isDIGIT($d)) {
+ $d++; $j++;
+ # maximum 3 digits between decimal
+ if ($strict && $j > 3) {
+ return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if ($d eq '_') {
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ if ( $alpha ) {
+ return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
+ }
+ $d++;
+ $alpha = TRUE;
+ }
+ elsif ($d eq '.') {
+ if ($alpha) {
+ return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
+ }
+ $saw_decimal++;
+ $d++;
+ }
+ elsif (!isDIGIT($d)) {
+ last;
+ }
+ $j = 0;
+ }
+
+ if ($strict && $i < 2) {
+ # requires v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } # end if dotted-decimal
+ else
+ { # decimal versions
+ my $j = 0;
+ # special $strict case for leading '.' or '0'
+ if ($strict) {
+ if ($d eq '.') {
+ return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
+ }
+ if ($d eq '0' && isDIGIT($d+1)) {
+ return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ # and we never support negative version numbers
+ if ($d eq '-') {
+ return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
+ }
+
+ # consume all of the integer part
+ while (isDIGIT($d)) {
+ $d++;
+ }
+
+ # look for a fractional part
+ if ($d eq '.') {
+ # we found it, so consume it
+ $saw_decimal++;
+ $d++;
+ }
+ elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
+ if ( $d == $s ) {
+ # found nothing
+ return BADVERSION($s,$errstr,"Invalid version format (version required)");
+ }
+ # found just an integer
+ goto version_prescan_finish;
+ }
+ elsif ( $d == $s ) {
+ # didn't find either integer or period
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+ elsif ($d eq '_') {
+ # underscore can't come after integer part
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ elsif (isDIGIT($d+1)) {
+ return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ elsif ($d) {
+ # anything else after integer part is just invalid data
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+
+ # scan the fractional part after the decimal point
+ if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
+ # $strict or lax-but-not-the-end
+ return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT($d)) {
+ $d++; $j++;
+ if ($d eq '.' && isDIGIT($d-1)) {
+ if ($alpha) {
+ return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
+ }
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ $d = $s; # start all over again
+ $qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if ($d eq '_') {
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ if ( $alpha ) {
+ return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT($d+1) ) {
+ return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
+ }
+ $width = $j;
+ $d++;
+ $alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE($d)) {
+ $d++;
+ }
+
+ if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
+ # trailing non-numeric data
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (defined $sqv) {
+ $$sqv = $qv;
+ }
+ if (defined $swidth) {
+ $$swidth = $width;
+ }
+ if (defined $ssaw_decimal) {
+ $$ssaw_decimal = $saw_decimal;
+ }
+ if (defined $salpha) {
+ $$salpha = $alpha;
+ }
+ return $d;
+}
+
+sub scan_version {
+ my ($s, $rv, $qv) = @_;
+ my $start;
+ my $pos;
+ my $last;
+ my $errstr;
+ my $saw_decimal = 0;
+ my $width = 3;
+ my $alpha = FALSE;
+ my $vinf = FALSE;
+ my @av;
+
+ $s = new charstar $s;
+
+ while (isSPACE($s)) { # leading whitespace is OK
+ $s++;
+ }
+
+ $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
+ \$width, \$alpha);
+
+ if ($errstr) {
+ # 'undef' is a special case and not an error
+ if ( $s ne 'undef') {
+ use Carp;
+ Carp::croak($errstr);
+ }
+ }
+
+ $start = $s;
+ if ($s eq 'v') {
+ $s++;
+ }
+ $pos = $s;
+
+ if ( $qv ) {
+ $$rv->{qv} = $qv;
+ }
+ if ( $alpha ) {
+ $$rv->{alpha} = $alpha;
+ }
+ if ( !$qv && $width < 3 ) {
+ $$rv->{width} = $width;
+ }
+
+ while (isDIGIT($pos)) {
+ $pos++;
+ }
+ if (!isALPHA($pos)) {
+ my $rev;
+
+ for (;;) {
+ $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_decimal == 1 ) {
+ $mult *= 100;
+ while ( $s < $end ) {
+ $orev = $rev;
+ $rev += $s * $mult;
+ $mult /= 10;
+ if ( (abs($orev) > abs($rev))
+ || (abs($rev) > $VERSION_MAX )) {
+ warn("Integer overflow in version %d",
+ $VERSION_MAX);
+ $s = $end - 1;
+ $rev = $VERSION_MAX;
+ $vinf = 1;
+ }
+ $s++;
+ if ( $s eq '_' ) {
+ $s++;
+ }
+ }
+ }
+ else {
+ while (--$end >= $s) {
+ $orev = $rev;
+ $rev += $end * $mult;
+ $mult *= 10;
+ if ( (abs($orev) > abs($rev))
+ || (abs($rev) > $VERSION_MAX )) {
+ warn("Integer overflow in version");
+ $end = $s - 1;
+ $rev = $VERSION_MAX;
+ $vinf = 1;
+ }
+ }
+ }
+ }
+
+ # Append revision
+ push @av, $rev;
+ if ( $vinf ) {
+ $s = $last;
+ last;
+ }
+ elsif ( $pos eq '.' ) {
+ $s = ++$pos;
+ }
+ elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
+ $s = ++$pos;
+ }
+ elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
+ $s = ++$pos;
+ }
+ elsif ( isDIGIT($pos) ) {
+ $s = $pos;
+ }
+ else {
+ $s = $pos;
+ last;
+ }
+ if ( $qv ) {
+ while ( isDIGIT($pos) ) {
+ $pos++;
+ }
+ }
+ else {
+ my $digits = 0;
+ while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
+ if ( $pos ne '_' ) {
+ $digits++;
+ }
+ $pos++;
+ }
+ }
+ }
+ }
+ if ( $qv ) { # quoted versions always get at least three terms
+ my $len = $#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:
+ # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
+ # for ( len = 2 - len; len > 0; len-- )
+ # av_push(MUTABLE_AV(sv), newSViv(0));
+ #
+ $len = 2 - $len;
+ while ($len-- > 0) {
+ push @av, 0;
+ }
+ }
+
+ # need to save off the current version string for later
+ if ( $vinf ) {
+ $$rv->{original} = "v.Inf";
+ $$rv->{vinf} = 1;
+ }
+ elsif ( $s > $start ) {
+ $$rv->{original} = $start->currstr($s);
+ if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
+ # need to insert a v to be consistent
+ $$rv->{original} = 'v' . $$rv->{original};
+ }
+ }
+ else {
+ $$rv->{original} = '0';
+ push(@av, 0);
+ }
+
+ # And finally, store the AV in the hash
+ $$rv->{version} = \@av;
+
+ # fix RT#19517 - special case 'undef' as string
+ if ($s eq 'undef') {
+ $s += 5;
+ }
+
+ 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;
+
+ 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 $currlocale = setlocale(LC_ALL);
+
+ # if the current locale uses commas for decimal points, we
+ # just replace commas with decimal places, rather than changing
+ # locales
+ if ( localeconv()->{decimal_point} eq ',' ) {
+ $value =~ tr/,/./;
+ }
+
+ if ( 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;
+ }
+
+ if (ref($value) =~ m/ARRAY|HASH/) {
+ require Carp;
+ Carp::croak("Invalid version format (non-numeric data)");
+ }
+
+ $value = _un_vstring($value);
+
+ # 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);
+
+ if ($s) { # must be something left over
+ warn("Version string '%s' contains invalid data; "
+ ."ignoring: '%s'", $value, $s);
+ }
+
+ return ($self);
+}
+
+*parse = \&new;
+
+sub numify
+{
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("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)) {
+ require Carp;
+ Carp::croak("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)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ return exists $self->{original}
+ ? $self->{original}
+ : exists $self->{qv}
+ ? $self->normal
+ : $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)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ unless (_verify($right)) {
+ require Carp;
+ Carp::croak("Invalid version format");
+ }
+ 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 vbool {
+ my ($self) = @_;
+ return vcmp($self,$self->new("0"),1);
+}
+
+sub vnoop {
+ require Carp;
+ Carp::croak("operation not supported with version object");
+}
+
+sub is_alpha {
+ my ($self) = @_;
+ return (exists $self->{alpha});
+}
+
+sub qv {
+ my $value = shift;
+ my $class = $CLASS;
+ if (@_) {
+ $class = ref($value) || $value;
+ $value = shift;
+ }
+
+ $value = _un_vstring($value);
+ $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
+ my $obj = $CLASS->new($value);
+ return bless $obj, $class;
+}
+
+*declare = \&qv;
+
+sub is_qv {
+ my ($self) = @_;
+ return (exists $self->{qv});
+}
+
+
+sub _verify {
+ my ($self) = @_;
+ if ( ref($self)
+ && eval { exists $self->{version} }
+ && ref($self->{version}) eq 'ARRAY'
+ ) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+sub _is_non_alphanumeric {
+ my $s = shift;
+ $s = new charstar $s;
+ while ($s) {
+ return 0 if isSPACE($s); # early out
+ return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
+ $s++;
+ }
+ return 0;
+}
+
+sub _un_vstring {
+ my $value = shift;
+ # may be a v-string
+ if ( length($value) >= 3 && $value !~ /[._]/
+ && _is_non_alphanumeric($value)) {
+ my $tvalue;
+ if ( $] ge 5.008_001 ) {
+ $tvalue = _find_magic_vstring($value);
+ $value = $tvalue if length $tvalue;
+ }
+ elsif ( $] ge 5.006_000 ) {
+ $tvalue = sprintf("v%vd",$value);
+ if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
+ # must be a v-string
+ $value = $tvalue;
+ }
+ }
+ }
+ return $value;
+}
+
+sub _find_magic_vstring {
+ my $value = shift;
+ my $tvalue = '';
+ require B;
+ my $sv = B::svref_2object(\$value);
+ my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
+ while ( $magic ) {
+ if ( $magic->TYPE eq 'V' ) {
+ $tvalue = $magic->PTR;
+ $tvalue =~ s/^v?(.+)$/v$1/;
+ last;
+ }
+ else {
+ $magic = $magic->MOREMAGIC;
+ }
+ }
+ return $tvalue;
+}
+
+sub _VERSION {
+ my ($obj, $req) = @_;
+ my $class = ref($obj) || $obj;
+
+ no strict 'refs';
+ if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
+ # file but no package
+ require Carp;
+ Carp::croak( "$class defines neither package nor VERSION"
+ ."--version check failed");
+ }
+
+ my $version = eval "\$$class\::VERSION";
+ if ( defined $version ) {
+ local $^W if $] <= 5.008;
+ $version = version::vpp->new($version);
+ }
+
+ if ( defined $req ) {
+ unless ( defined $version ) {
+ require Carp;
+ my $msg = $] < 5.006
+ ? "$class version $req required--this is only version "
+ : "$class does not define \$$class\::VERSION"
+ ."--version check failed";
+
+ if ( $ENV{VERSION_DEBUG} ) {
+ Carp::confess($msg);
+ }
+ else {
+ Carp::croak($msg);
+ }
+ }
+
+ $req = version::vpp->new($req);
+
+ if ( $req > $version ) {
+ require Carp;
+ if ( $req->is_qv ) {
+ Carp::croak(
+ sprintf ("%s version %s required--".
+ "this is only version %s", $class,
+ $req->normal, $version->normal)
+ );
+ }
+ else {
+ Carp::croak(
+ sprintf ("%s version %s required--".
+ "this is only version %s", $class,
+ $req->stringify, $version->stringify)
+ );
+ }
+ }
+ }
+
+ return defined $version ? $version->stringify : undef;
+}
+
+1; #this line is important and will help the module return a true value
diff --git a/cpan/version/t/00impl-pp.t b/cpan/version/t/00impl-pp.t
new file mode 100644
index 0000000000..36026aa2d2
--- /dev/null
+++ b/cpan/version/t/00impl-pp.t
@@ -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.9905);
+}
+
+BaseTests("version::vpp","new","qv");
+BaseTests("version::vpp","new","declare");
+BaseTests("version::vpp","parse", "qv");
+BaseTests("version::vpp","parse", "declare");
diff --git a/cpan/version/t/01base.t b/cpan/version/t/01base.t
index 7e83058cd7..681a0ffc89 100644
--- a/cpan/version/t/01base.t
+++ b/cpan/version/t/01base.t
@@ -9,7 +9,7 @@ use Test::More qw/no_plan/;
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok('version', 0.9904);
+ use_ok('version', 0.9905);
}
BaseTests("version","new","qv");
diff --git a/cpan/version/t/02derived.t b/cpan/version/t/02derived.t
index 6ed9524a1a..8cf27432d5 100644
--- a/cpan/version/t/02derived.t
+++ b/cpan/version/t/02derived.t
@@ -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.9905);
# 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
diff --git a/cpan/version/t/03require.t b/cpan/version/t/03require.t
index d579579629..873fada246 100644
--- a/cpan/version/t/03require.t
+++ b/cpan/version/t/03require.t
@@ -14,7 +14,7 @@ BEGIN {
# Don't want to use, because we need to make sure that the import doesn't
# fire just yet (some code does this to avoid importing qv() and delare()).
require_ok("version");
-is $version::VERSION, 0.9904, "Make sure we have the correct class";
+is $version::VERSION, 0.9905, "Make sure we have the correct class";
ok(!"main"->can("qv"), "We don't have the imported qv()");
ok(!"main"->can("declare"), "We don't have the imported declare()");
diff --git a/cpan/version/t/05sigdie.t b/cpan/version/t/05sigdie.t
index bac5534a86..3496f5771c 100644
--- a/cpan/version/t/05sigdie.t
+++ b/cpan/version/t/05sigdie.t
@@ -14,7 +14,7 @@ BEGIN {
}
BEGIN {
- use version 0.9904;
+ use version 0.9905;
}
pass "Didn't get caught by the wrong DIE handler, which is a good thing";
diff --git a/cpan/version/t/06noop.t b/cpan/version/t/06noop.t
index e26532f9bc..74e7251c54 100644
--- a/cpan/version/t/06noop.t
+++ b/cpan/version/t/06noop.t
@@ -7,7 +7,7 @@
use Test::More qw/no_plan/;
BEGIN {
- use_ok('version', 0.9904);
+ use_ok('version', 0.9905);
}
my $v1 = version->new('1.2');
diff --git a/cpan/version/t/07locale.t b/cpan/version/t/07locale.t
index 93662edec8..a3c75c0bf5 100644
--- a/cpan/version/t/07locale.t
+++ b/cpan/version/t/07locale.t
@@ -11,7 +11,7 @@ use Test::More tests => 7;
use Config;
BEGIN {
- use_ok('version', 0.9904);
+ use_ok('version', 0.9905);
}
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,15 +31,18 @@ SKIP: {
# because have to
# evaluate in current
# scope
+ use 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 ',';
setlocale(LC_NUMERIC, $loc);
+ $ver = 1.23; # has to be floating point number
ok ($ver eq "1,23", "Using locale: $loc");
$v = version->new($ver);
unlike($warning, qr/Version string '1,23' contains invalid data/,
diff --git a/cpan/version/t/08_corelist.t b/cpan/version/t/08_corelist.t
index 5e548a9d7e..9a8e4742f1 100644
--- a/cpan/version/t/08_corelist.t
+++ b/cpan/version/t/08_corelist.t
@@ -4,17 +4,19 @@
#########################
-use Test::More tests => 2;
-use_ok("version", 0.9904);
+use Test::More tests => 3;
+use_ok("version", 0.9905);
# do strict lax tests in a sub to isolate a package to test importing
SKIP: {
eval "use Module::CoreList 2.76";
- skip 'No tied hash in Modules::CoreList in Perl', 1
+ skip 'No tied hash in Modules::CoreList in Perl', 2
if $@;
my $foo = version->parse($Module::CoreList::version{5.008_000}{base});
- is $foo, $Module::CoreList::version{5.008_000}{base},
- 'Correctly handle tied hash';
+ is $foo, 1.03, 'Correctly handle tied hash';
+
+ $foo = version->qv($Module::CoreList::version{5.008_000}{Unicode});
+ is $foo, '3.2.0', 'Correctly handle tied hash with dotted decimal';
}
diff --git a/cpan/version/t/09_list_util.t b/cpan/version/t/09_list_util.t
new file mode 100644
index 0000000000..f7fb89f021
--- /dev/null
+++ b/cpan/version/t/09_list_util.t
@@ -0,0 +1,37 @@
+# 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 Test::More tests => 3;
+use_ok("version", 0.9905);
+
+# do strict lax tests in a sub to isolate a package to test importing
+SKIP: {
+ eval "use List::Util qw(reduce);";
+ skip 'No reduce() in List::Util', 2
+ if $@;
+
+ # 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';
+ }
+}
diff --git a/cpan/version/t/coretests.pm b/cpan/version/t/coretests.pm
index 080b6ae32f..17bf9ec5fc 100644
--- a/cpan/version/t/coretests.pm
+++ b/cpan/version/t/coretests.pm
@@ -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;
diff --git a/t/porting/customized.dat b/t/porting/customized.dat
index 9da61bec41..d5c06dd6da 100644
--- a/t/porting/customized.dat
+++ b/t/porting/customized.dat
@@ -16,6 +16,6 @@ autodie cpan/autodie/t/utf8_open.t 5295851351c49f939008c5aca6a798742b1e503d
libnet cpan/libnet/Makefile.PL 6b10ac98e672bfebb8f49b9720a93442645208b3
podlators cpan/podlators/scripts/pod2man.PL f81acf53f3ff46cdcc5ebdd661c5d13eb35d20d6
podlators cpan/podlators/scripts/pod2text.PL b4693fcfe4a0a1b38a215cfb8985a65d5d025d69
-version cpan/version/lib/version.pm e9d5df9a053ac6882c6e73f7e29db74e01b15841
-version cpan/version/t/07locale.t c7e86c2706622d5055b617a4b0119ea874be8a7b
-version cpan/version/t/08_corelist.t bd1c900f8be98e87dbf88896b8337f0694e4b4d3
+version cpan/version/lib/version.pm 65f739f72dda1a45f497f38217883facefd0c873
+version cpan/version/t/07locale.t bbc7f94bc2ad633978aedb5732b8b4ad6b3247fb
+version cpan/version/t/08_corelist.t 1c10cc05162c99b02cd45f9b9fb9a310aa2bff10
diff --git a/universal.c b/universal.c
index 229b05dcfd..2861d31cc5 100644
--- a/universal.c
+++ b/universal.c
@@ -416,382 +416,6 @@ XS(XS_UNIVERSAL_DOES)
}
}
-XS(XS_UNIVERSAL_VERSION)
-{
- dVAR;
- dXSARGS;
- HV *pkg;
- GV **gvp;
- GV *gv;
- SV *sv;
- const char *undef;
- PERL_UNUSED_ARG(cv);
-
- if (SvROK(ST(0))) {
- sv = MUTABLE_SV(SvRV(ST(0)));
- if (!SvOBJECT(sv))
- Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
- pkg = SvSTASH(sv);
- }
- else {
- pkg = gv_stashsv(ST(0), 0);
- }
-
- gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
-
- if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
- SV * const nsv = sv_newmortal();
- sv_setsv(nsv, sv);
- sv = nsv;
- if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
- 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 HEK * const name = HvNAME_HEK(pkg);
- Perl_croak(aTHX_
- "%"HEKf" does not define $%"HEKf
- "::VERSION--version check failed",
- HEKfARG(name), HEKfARG(name));
- } else {
- Perl_croak(aTHX_
- "%"SVf" defines neither package nor VERSION--version check failed",
- SVfARG(ST(0)) );
- }
- }
-
- if ( !sv_isobject(req) || !sv_derived_from(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 ) ) {
- Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
- "this is only version %"SVf"",
- HEKfARG(HvNAME_HEK(pkg)),
- SVfARG(sv_2mortal(vnormal(req))),
- SVfARG(sv_2mortal(vnormal(sv))));
- } else {
- Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
- "this is only version %"SVf,
- HEKfARG(HvNAME_HEK(pkg)),
- SVfARG(sv_2mortal(vstringify(req))),
- SVfARG(sv_2mortal(vstringify(sv))));
- }
- }
-
- }
-
- if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
- ST(0) = sv_2mortal(vstringify(sv));
- } else {
- ST(0) = sv;
- }
-
- XSRETURN(1);
-}
-
-XS(XS_version_new)
-{
- dVAR;
- dXSARGS;
- if (items > 3 || items < 1)
- croak_xs_usage(cv, "class, version");
- SP -= items;
- {
- SV *vs = ST(1);
- SV *rv;
- STRLEN len;
- const char *classname;
- U32 flags;
-
- /* Just in case this is something like a tied hash */
- SvGETMAGIC(vs);
-
- if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
- const HV * stash = SvSTASH(SvRV(ST(0)));
- classname = HvNAME(stash);
- len = HvNAMELEN(stash);
- flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
- }
- else {
- classname = SvPV(ST(0), len);
- flags = SvUTF8(ST(0));
- }
-
- if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
- /* create empty object */
- vs = sv_newmortal();
- sv_setpvs(vs, "0");
- }
- else if ( items == 3 ) {
- vs = sv_newmortal();
- Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
- }
-
- rv = new_version(vs);
- if ( strnNE(classname,"version", len) ) /* inherited new() */
- sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
-
- mPUSHs(rv);
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_stringify)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- mPUSHs(vstringify(lobj));
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_numify)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- mPUSHs(vnumify(lobj));
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_normal)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- mPUSHs(vnormal(lobj));
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_vcmp)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- {
- SV *rs;
- SV *rvs;
- SV * robj = ST(1);
- const IV swap = (IV)SvIV(ST(2));
-
- if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
- {
- robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
- sv_2mortal(robj);
- }
- rvs = SvRV(robj);
-
- if ( swap )
- {
- rs = newSViv(vcmp(rvs,lobj));
- }
- else
- {
- rs = newSViv(vcmp(lobj,rvs));
- }
-
- mPUSHs(rs);
- }
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_boolean)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
- SV * const lobj = SvRV(ST(0));
- SV * const rs =
- newSViv( vcmp(lobj,
- sv_2mortal(new_version(
- sv_2mortal(newSVpvs("0"))
- ))
- )
- );
- mPUSHs(rs);
- PUTBACK;
- return;
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-}
-
-XS(XS_version_noop)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
- Perl_croak(aTHX_ "operation not supported with version object");
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-#ifndef HASATTRIBUTE_NORETURN
- XSRETURN_EMPTY;
-#endif
-}
-
-XS(XS_version_is_alpha)
-{
- dVAR;
- dXSARGS;
- if (items != 1)
- croak_xs_usage(cv, "lobj");
- SP -= items;
- if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
- SV * const lobj = ST(0);
- if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
- XSRETURN_YES;
- else
- XSRETURN_NO;
- PUTBACK;
- return;
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-}
-
-XS(XS_version_qv)
-{
- dVAR;
- dXSARGS;
- PERL_UNUSED_ARG(cv);
- SP -= items;
- {
- SV * ver = ST(0);
- SV * rv;
- STRLEN len = 0;
- const char * classname = "";
- U32 flags = 0;
- if ( items == 2 ) {
- SvGETMAGIC(ST(1));
- if (SvOK(ST(1))) {
- ver = ST(1);
- }
- else {
- Perl_croak(aTHX_ "Invalid version format (version required)");
- }
- if ( sv_isobject(ST(0)) ) { /* class called as an object method */
- const HV * stash = SvSTASH(SvRV(ST(0)));
- classname = HvNAME(stash);
- len = HvNAMELEN(stash);
- flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
- }
- else {
- classname = SvPV(ST(0), len);
- flags = SvUTF8(ST(0));
- }
- }
- if ( !SvVOK(ver) ) { /* not already a v-string */
- rv = sv_newmortal();
- sv_setsv(rv,ver); /* make a duplicate */
- upg_version(rv, TRUE);
- } else {
- rv = sv_2mortal(new_version(ver));
- }
- if ( items == 2
- && strnNE(classname,"version", len) ) { /* inherited new() */
- sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
- }
- PUSHs(rv);
- }
- PUTBACK;
- return;
-}
-
-XS(XS_version_is_qv)
-{
- dVAR;
- dXSARGS;
- if (items != 1)
- croak_xs_usage(cv, "lobj");
- SP -= items;
- if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
- SV * const lobj = ST(0);
- if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
- XSRETURN_YES;
- else
- XSRETURN_NO;
- PUTBACK;
- return;
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-}
-
XS(XS_utf8_is_utf8)
{
dVAR;
@@ -1372,6 +996,9 @@ XS(XS_re_regexp_pattern)
/* NOT-REACHED */
}
+#include "vutil.h"
+#include "vxs.inc"
+
struct xsub_details {
const char *name;
XSUBADDR_t xsub;
@@ -1382,35 +1009,9 @@ static const struct xsub_details details[] = {
{"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
{"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
{"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
- {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
- {"version::()", XS_version_noop, NULL},
- {"version::new", XS_version_new, NULL},
- {"version::parse", XS_version_new, NULL},
- {"version::(\"\"", XS_version_stringify, NULL},
- {"version::stringify", XS_version_stringify, NULL},
- {"version::(0+", XS_version_numify, NULL},
- {"version::numify", XS_version_numify, NULL},
- {"version::normal", XS_version_normal, NULL},
- {"version::(cmp", XS_version_vcmp, NULL},
- {"version::(<=>", XS_version_vcmp, NULL},
- {"version::vcmp", XS_version_vcmp, NULL},
- {"version::(bool", XS_version_boolean, NULL},
- {"version::boolean", XS_version_boolean, NULL},
- {"version::(+", XS_version_noop, NULL},
- {"version::(-", XS_version_noop, NULL},
- {"version::(*", XS_version_noop, NULL},
- {"version::(/", XS_version_noop, NULL},
- {"version::(+=", XS_version_noop, NULL},
- {"version::(-=", XS_version_noop, NULL},
- {"version::(*=", XS_version_noop, NULL},
- {"version::(/=", XS_version_noop, NULL},
- {"version::(abs", XS_version_noop, NULL},
- {"version::(nomethod", XS_version_noop, NULL},
- {"version::noop", XS_version_noop, NULL},
- {"version::is_alpha", XS_version_is_alpha, NULL},
- {"version::qv", XS_version_qv, NULL},
- {"version::declare", XS_version_qv, NULL},
- {"version::is_qv", XS_version_is_qv, NULL},
+#define VXS_XSUB_DETAILS
+#include "vxs.inc"
+#undef VXS_XSUB_DETAILS
{"utf8::is_utf8", XS_utf8_is_utf8, NULL},
{"utf8::valid", XS_utf8_valid, NULL},
{"utf8::encode", XS_utf8_encode, NULL},
diff --git a/util.c b/util.c
index 596955b059..f308e93a84 100644
--- a/util.c
+++ b/util.c
@@ -3919,945 +3919,7 @@ Perl_getcwd_sv(pTHX_ SV *sv)
#endif
}
-#define VERSION_MAX 0x7FFFFFFF
-
-/*
-=for apidoc prescan_version
-
-Validate that a given string can be parsed as a version object, but doesn't
-actually perform the parsing. Can use either strict or lax validation rules.
-Can optionally set a number of hint variables to save the parsing code
-some time when tokenizing.
-
-=cut
-*/
-const char *
-Perl_prescan_version(pTHX_ const char *s, bool strict,
- const char **errstr,
- bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
- bool qv = (sqv ? *sqv : FALSE);
- int width = 3;
- int saw_decimal = 0;
- bool alpha = FALSE;
- const char *d = s;
-
- PERL_ARGS_ASSERT_PRESCAN_VERSION;
-
- if (qv && isDIGIT(*d))
- goto dotted_decimal_version;
-
- if (*d == 'v') { /* explicit v-string */
- d++;
- if (isDIGIT(*d)) {
- qv = TRUE;
- }
- else { /* degenerate v-string */
- /* requires v1.2.3 */
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
-
-dotted_decimal_version:
- if (strict && d[0] == '0' && isDIGIT(d[1])) {
- /* no leading zeros allowed */
- BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
- }
-
- while (isDIGIT(*d)) /* integer part */
- d++;
-
- if (*d == '.')
- {
- saw_decimal++;
- d++; /* decimal point */
- }
- else
- {
- if (strict) {
- /* require v1.2.3 */
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
- else {
- goto version_prescan_finish;
- }
- }
-
- {
- int i = 0;
- int j = 0;
- while (isDIGIT(*d)) { /* just keep reading */
- i++;
- while (isDIGIT(*d)) {
- d++; j++;
- /* maximum 3 digits between decimal */
- if (strict && j > 3) {
- BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
- }
- }
- if (*d == '_') {
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (no underscores)");
- }
- if ( alpha ) {
- BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
- }
- d++;
- alpha = TRUE;
- }
- else if (*d == '.') {
- if (alpha) {
- BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
- }
- saw_decimal++;
- d++;
- }
- else if (!isDIGIT(*d)) {
- break;
- }
- j = 0;
- }
-
- if (strict && i < 2) {
- /* requires v1.2.3 */
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
- }
- } /* end if dotted-decimal */
- else
- { /* decimal versions */
- int j = 0; /* may need this later */
- /* special strict case for leading '.' or '0' */
- if (strict) {
- if (*d == '.') {
- BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
- }
- if (*d == '0' && isDIGIT(d[1])) {
- BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
- }
- }
-
- /* and we never support negative versions */
- if ( *d == '-') {
- BADVERSION(s,errstr,"Invalid version format (negative version number)");
- }
-
- /* consume all of the integer part */
- while (isDIGIT(*d))
- d++;
-
- /* look for a fractional part */
- if (*d == '.') {
- /* we found it, so consume it */
- saw_decimal++;
- d++;
- }
- else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
- if ( d == s ) {
- /* found nothing */
- BADVERSION(s,errstr,"Invalid version format (version required)");
- }
- /* found just an integer */
- goto version_prescan_finish;
- }
- else if ( d == s ) {
- /* didn't find either integer or period */
- BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
- }
- else if (*d == '_') {
- /* underscore can't come after integer part */
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (no underscores)");
- }
- else if (isDIGIT(d[1])) {
- BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
- }
- else {
- BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
- }
- }
- else {
- /* anything else after integer part is just invalid data */
- BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
- }
-
- /* scan the fractional part after the decimal point*/
-
- if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
- /* strict or lax-but-not-the-end */
- BADVERSION(s,errstr,"Invalid version format (fractional part required)");
- }
-
- while (isDIGIT(*d)) {
- d++; j++;
- if (*d == '.' && isDIGIT(d[-1])) {
- if (alpha) {
- BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
- }
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
- }
- d = (char *)s; /* start all over again */
- qv = TRUE;
- goto dotted_decimal_version;
- }
- if (*d == '_') {
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (no underscores)");
- }
- if ( alpha ) {
- BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
- }
- if ( ! isDIGIT(d[1]) ) {
- BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
- }
- width = j;
- d++;
- alpha = TRUE;
- }
- }
- }
-
-version_prescan_finish:
- while (isSPACE(*d))
- d++;
-
- if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
- /* trailing non-numeric data */
- BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
- }
-
- if (sqv)
- *sqv = qv;
- if (swidth)
- *swidth = width;
- if (ssaw_decimal)
- *ssaw_decimal = saw_decimal;
- if (salpha)
- *salpha = alpha;
- return d;
-}
-
-/*
-=for apidoc scan_version
-
-Returns a pointer to the next character after the parsed
-version string, as well as upgrading the passed in SV to
-an RV.
-
-Function must be called with an already existing SV like
-
- sv = newSV(0);
- s = scan_version(s, SV *sv, bool qv);
-
-Performs some preprocessing to the string to ensure that
-it has the correct characteristics of a version. Flags the
-object if it contains an underscore (which denotes this
-is an alpha version). The boolean qv denotes that the version
-should be interpreted as if it had multiple decimals, even if
-it doesn't.
-
-=cut
-*/
-
-const char *
-Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
-{
- const char *start = s;
- const char *pos;
- const char *last;
- const char *errstr = NULL;
- int saw_decimal = 0;
- int width = 3;
- bool alpha = FALSE;
- bool vinf = FALSE;
- AV * av;
- SV * hv;
-
- PERL_ARGS_ASSERT_SCAN_VERSION;
-
- while (isSPACE(*s)) /* leading whitespace is OK */
- s++;
-
- 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);
- Perl_croak(aTHX_ "%s", errstr);
- }
- }
-
- start = s;
- if (*s == 'v')
- s++;
- pos = s;
-
- /* Now that we are through the prescan, start creating the object */
- av = newAV();
- hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
- (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-
-#ifndef NODEFAULT_SHAREKEYS
- HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
-
- if ( qv )
- (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
- if ( alpha )
- (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
- if ( !qv && width < 3 )
- (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-
- while (isDIGIT(*pos))
- pos++;
- if (!isALPHA(*pos)) {
- I32 rev;
-
- for (;;) {
- rev = 0;
- {
- /* this is atoi() that delimits on underscores */
- const char *end = pos;
- I32 mult = 1;
- I32 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_decimal == 1 ) {
- mult *= 100;
- while ( s < end ) {
- orev = rev;
- rev += (*s - '0') * mult;
- mult /= 10;
- if ( (PERL_ABS(orev) > PERL_ABS(rev))
- || (PERL_ABS(rev) > VERSION_MAX )) {
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version %d",VERSION_MAX);
- s = end - 1;
- rev = VERSION_MAX;
- vinf = 1;
- }
- s++;
- if ( *s == '_' )
- s++;
- }
- }
- else {
- while (--end >= s) {
- orev = rev;
- rev += (*end - '0') * mult;
- mult *= 10;
- if ( (PERL_ABS(orev) > PERL_ABS(rev))
- || (PERL_ABS(rev) > VERSION_MAX )) {
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version");
- end = s - 1;
- rev = VERSION_MAX;
- vinf = 1;
- }
- }
- }
- }
-
- /* Append revision */
- av_push(av, newSViv(rev));
- if ( vinf ) {
- s = last;
- break;
- }
- else if ( *pos == '.' )
- s = ++pos;
- else if ( *pos == '_' && isDIGIT(pos[1]) )
- s = ++pos;
- else if ( *pos == ',' && isDIGIT(pos[1]) )
- s = ++pos;
- else if ( isDIGIT(*pos) )
- s = pos;
- else {
- s = pos;
- break;
- }
- if ( qv ) {
- while ( isDIGIT(*pos) )
- pos++;
- }
- else {
- int digits = 0;
- while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
- if ( *pos != '_' )
- digits++;
- pos++;
- }
- }
- }
- }
- if ( qv ) { /* quoted versions always get at least three terms*/
- SSize_t len = av_len(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:
- gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
- for ( len = 2 - len; len > 0; len-- )
- av_push(MUTABLE_AV(sv), newSViv(0));
- */
- len = 2 - len;
- while (len-- > 0)
- av_push(av, newSViv(0));
- }
-
- /* need to save off the current version string for later */
- if ( vinf ) {
- SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
- (void)hv_stores(MUTABLE_HV(hv), "original", orig);
- (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
- }
- else if ( s > start ) {
- SV * orig = newSVpvn(start,s-start);
- if ( qv && saw_decimal == 1 && *start != 'v' ) {
- /* need to insert a v to be consistent */
- sv_insert(orig, 0, 0, "v", 1);
- }
- (void)hv_stores(MUTABLE_HV(hv), "original", orig);
- }
- else {
- (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
- av_push(av, newSViv(0));
- }
-
- /* And finally, store the AV in the hash */
- (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") ) {
- s += 5;
- }
-
- return s;
-}
-
-/*
-=for apidoc new_version
-
-Returns a new version object based on the passed in SV:
-
- SV *sv = new_version(SV *ver);
-
-Does not alter the passed in ver SV. See "upg_version" if you
-want to upgrade the SV.
-
-=cut
-*/
-
-SV *
-Perl_new_version(pTHX_ SV *ver)
-{
- dVAR;
- SV * const rv = newSV(0);
- PERL_ARGS_ASSERT_NEW_VERSION;
- if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
- /* can just copy directly */
- {
- SSize_t key;
- AV * const av = newAV();
- AV *sav;
- /* This will get reblessed later if a derived class*/
- SV * const hv = newSVrv(rv, "version");
- (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-#ifndef NODEFAULT_SHAREKEYS
- HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
-
- if ( SvROK(ver) )
- ver = SvRV(ver);
-
- /* Begin copying all of the elements */
- if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
- (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
-
- 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));
- }
-
- 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));
- }
-
- 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));
- av_push(av, newSViv(rev));
- }
-
- (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
- return rv;
- }
-#ifdef SvVOK
- {
- 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);
- 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 */
-#ifdef SvVOK
- }
- }
-#endif
- return upg_version(rv, FALSE);
-}
-
-/*
-=for apidoc upg_version
-
-In-place upgrade of the supplied SV to a version object.
-
- SV *sv = upg_version(SV *sv, bool qv);
-
-Returns a pointer to the upgraded SV. Set the boolean qv if you want
-to force this SV to be interpreted as an "extended" version.
-
-=cut
-*/
-
-SV *
-Perl_upg_version(pTHX_ SV *ver, bool qv)
-{
- const char *version, *s;
-#ifdef SvVOK
- const MAGIC *mg;
-#endif
-
- PERL_ARGS_ASSERT_UPG_VERSION;
-
- if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
- {
- STRLEN len;
-
- /* may get too much accuracy */
- 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
- if (sv) {
- Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
- buf = SvPV(sv, len);
- }
- 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
- while (buf[len-1] == '0' && len > 0) len--;
- if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
- version = savepvn(buf, len);
- 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 );
- qv = TRUE;
- }
-#endif
- else /* must be a string or something like a string */
- {
- STRLEN len;
- version = savepv(SvPV(ver,len));
-#ifndef SvVOK
-# if PERL_VERSION > 5
- /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
- if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
- /* may be a v-string */
- char *testv = (char *)version;
- STRLEN tlen = len;
- for (tlen=0; tlen < len; tlen++, testv++) {
- /* if one of the characters is non-text assume v-string */
- if (testv[0] < ' ') {
- SV * const nsv = sv_newmortal();
- const char *nver;
- const char *pos;
- int saw_decimal = 0;
- sv_setpvf(nsv,"v%vd",ver);
- pos = nver = savepv(SvPV_nolen(nsv));
-
- /* scan the resulting formatted string */
- pos++; /* skip the leading 'v' */
- while ( *pos == '.' || isDIGIT(*pos) ) {
- if ( *pos == '.' )
- saw_decimal++ ;
- pos++;
- }
-
- /* is definitely a v-string */
- if ( saw_decimal >= 2 ) {
- Safefree(version);
- version = nver;
- }
- break;
- }
- }
- }
-# endif
-#endif
- }
-
- 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);
- return ver;
-}
-
-/*
-=for apidoc vverify
-
-Validates that the SV contains valid internal structure for a version object.
-It may be passed either the version object (RV) or the hash itself (HV). If
-the structure is valid, it returns the HV. If the structure is invalid,
-it returns NULL.
-
- SV *hv = vverify(sv);
-
-Note that it only confirms the bare minimum structure (so as not to get
-confused by derived classes which may contain additional hash entries):
-
-=over 4
-
-=item * The SV is an HV or a reference to an HV
-
-=item * The hash contains a "version" key
-
-=item * The "version" key has a reference to an AV as its value
-
-=back
-
-=cut
-*/
-
-SV *
-Perl_vverify(pTHX_ SV *vs)
-{
- SV *sv;
-
- PERL_ARGS_ASSERT_VVERIFY;
-
- if ( SvROK(vs) )
- vs = SvRV(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)))
- && SvTYPE(sv) == SVt_PVAV )
- return vs;
- else
- return NULL;
-}
-
-/*
-=for apidoc vnumify
-
-Accepts a version object and returns the normalized floating
-point representation. Call like:
-
- sv = vnumify(rv);
-
-NOTE: you can pass either the object directly or the SV
-contained within the RV.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vnumify(pTHX_ SV *vs)
-{
- SSize_t i, len;
- I32 digit;
- int width;
- bool alpha = FALSE;
- SV *sv;
- AV *av;
-
- PERL_ARGS_ASSERT_VNUMIFY;
-
- /* extract the HV from the object */
- vs = vverify(vs);
- if ( ! vs )
- Perl_croak(aTHX_ "Invalid version object");
-
- /* 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;
-
-
- /* attempt to retrieve the version array */
- if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
- return newSVpvs("0");
- }
-
- len = av_len(av);
- if ( len == -1 )
- {
- return newSVpvs("0");
- }
-
- digit = SvIV(*av_fetch(av, 0, 0));
- sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
- for ( i = 1 ; i < len ; i++ )
- {
- digit = SvIV(*av_fetch(av, i, 0));
- if ( width < 3 ) {
- const int denom = (width == 2 ? 10 : 100);
- const div_t term = div((int)PERL_ABS(digit),denom);
- Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
- }
- else {
- Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
- }
- }
-
- if ( len > 0 )
- {
- digit = SvIV(*av_fetch(av, len, 0));
- if ( alpha && width == 3 ) /* alpha version */
- sv_catpvs(sv,"_");
- Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
- }
- else /* len == 0 */
- {
- sv_catpvs(sv, "000");
- }
- return sv;
-}
-
-/*
-=for apidoc vnormal
-
-Accepts a version object and returns the normalized string
-representation. Call like:
-
- sv = vnormal(rv);
-
-NOTE: you can pass either the object directly or the SV
-contained within the RV.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vnormal(pTHX_ SV *vs)
-{
- I32 i, len, digit;
- bool alpha = FALSE;
- SV *sv;
- AV *av;
-
- PERL_ARGS_ASSERT_VNORMAL;
-
- /* extract the HV from the object */
- vs = vverify(vs);
- if ( ! vs )
- Perl_croak(aTHX_ "Invalid version object");
-
- if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
- alpha = TRUE;
- av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
-
- len = av_len(av);
- if ( len == -1 )
- {
- return newSVpvs("");
- }
- digit = SvIV(*av_fetch(av, 0, 0));
- sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
- for ( i = 1 ; i < len ; i++ ) {
- digit = SvIV(*av_fetch(av, i, 0));
- Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
- }
-
- if ( len > 0 )
- {
- /* handle last digit specially */
- digit = SvIV(*av_fetch(av, len, 0));
- if ( alpha )
- Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
- else
- Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
- }
-
- if ( len <= 2 ) { /* short version, must be at least three */
- for ( len = 2 - len; len != 0; len-- )
- sv_catpvs(sv,".0");
- }
- return sv;
-}
-
-/*
-=for apidoc vstringify
-
-In order to maintain maximum compatibility with earlier versions
-of Perl, this function will return either the floating point
-notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vstringify(pTHX_ SV *vs)
-{
- PERL_ARGS_ASSERT_VSTRINGIFY;
-
- /* extract the HV from the object */
- vs = vverify(vs);
- if ( ! vs )
- Perl_croak(aTHX_ "Invalid version object");
-
- if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
- SV *pv;
- pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
- if ( SvPOK(pv) )
- return newSVsv(pv);
- else
- return &PL_sv_undef;
- }
- else {
- if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
- return vnormal(vs);
- else
- return vnumify(vs);
- }
-}
-
-/*
-=for apidoc vcmp
-
-Version object aware cmp. Both operands must already have been
-converted into version objects.
-
-=cut
-*/
-
-int
-Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
-{
- SSize_t i,l,m,r;
- I32 retval;
- bool lalpha = FALSE;
- bool ralpha = FALSE;
- I32 left = 0;
- I32 right = 0;
- AV *lav, *rav;
-
- PERL_ARGS_ASSERT_VCMP;
-
- /* extract the HVs from the objects */
- lhv = vverify(lhv);
- rhv = vverify(rhv);
- if ( ! ( lhv && rhv ) )
- Perl_croak(aTHX_ "Invalid version object");
-
- /* get the left hand term */
- lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
- if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
- lalpha = TRUE;
-
- /* and the right hand term */
- rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
- if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
- ralpha = TRUE;
-
- l = av_len(lav);
- r = av_len(rav);
- m = l < r ? l : r;
- retval = 0;
- i = 0;
- while ( i <= m && retval == 0 )
- {
- left = SvIV(*av_fetch(lav,i,0));
- right = SvIV(*av_fetch(rav,i,0));
- if ( left < right )
- retval = -1;
- if ( left > right )
- retval = +1;
- i++;
- }
-
- /* tiebreaker for alpha with identical terms */
- if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
- {
- if ( lalpha && !ralpha )
- {
- retval = -1;
- }
- else if ( ralpha && !lalpha)
- {
- retval = +1;
- }
- }
-
- if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
- {
- if ( l < r )
- {
- while ( i <= r && retval == 0 )
- {
- if ( SvIV(*av_fetch(rav,i,0)) != 0 )
- retval = -1; /* not a match after all */
- i++;
- }
- }
- else
- {
- while ( i <= l && retval == 0 )
- {
- if ( SvIV(*av_fetch(lav,i,0)) != 0 )
- retval = +1; /* not a match after all */
- i++;
- }
- }
- }
- return retval;
-}
+#include "vutil.c"
#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
# define EMULATE_SOCKETPAIR_UDP
diff --git a/vutil.c b/vutil.c
new file mode 100644
index 0000000000..06680dd6fb
--- /dev/null
+++ b/vutil.c
@@ -0,0 +1,1009 @@
+/* This file is part of the "version" CPAN distribution. Please avoid
+ editing it in the perl core. */
+
+#ifndef PERL_CORE
+# 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
+
+/*
+=for apidoc prescan_version
+
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing. Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
+=cut
+*/
+const char *
+#if VUTIL_REPLACE_CORE
+Perl_prescan_version2(pTHX_ const char *s, bool strict,
+#else
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+#endif
+ const char **errstr,
+ bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+ bool qv = (sqv ? *sqv : FALSE);
+ int width = 3;
+ int saw_decimal = 0;
+ bool alpha = FALSE;
+ const char *d = s;
+
+ PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+ if (qv && isDIGIT(*d))
+ goto dotted_decimal_version;
+
+ if (*d == 'v') { /* explicit v-string */
+ d++;
+ if (isDIGIT(*d)) {
+ qv = TRUE;
+ }
+ else { /* degenerate v-string */
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if (strict && d[0] == '0' && isDIGIT(d[1])) {
+ /* no leading zeros allowed */
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT(*d)) /* integer part */
+ d++;
+
+ if (*d == '.')
+ {
+ saw_decimal++;
+ d++; /* decimal point */
+ }
+ else
+ {
+ if (strict) {
+ /* require v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ int i = 0;
+ int j = 0;
+ while (isDIGIT(*d)) { /* just keep reading */
+ i++;
+ while (isDIGIT(*d)) {
+ d++; j++;
+ /* maximum 3 digits between decimal */
+ if (strict && j > 3) {
+ BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ else if (*d == '.') {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ saw_decimal++;
+ d++;
+ }
+ else if (!isDIGIT(*d)) {
+ break;
+ }
+ j = 0;
+ }
+
+ if (strict && i < 2) {
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } /* end if dotted-decimal */
+ else
+ { /* decimal versions */
+ int j = 0; /* may need this later */
+ /* special strict case for leading '.' or '0' */
+ if (strict) {
+ if (*d == '.') {
+ BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+ }
+ if (*d == '0' && isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ /* and we never support negative versions */
+ if ( *d == '-') {
+ BADVERSION(s,errstr,"Invalid version format (negative version number)");
+ }
+
+ /* consume all of the integer part */
+ while (isDIGIT(*d))
+ d++;
+
+ /* look for a fractional part */
+ if (*d == '.') {
+ /* we found it, so consume it */
+ saw_decimal++;
+ d++;
+ }
+ else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
+ if ( d == s ) {
+ /* found nothing */
+ BADVERSION(s,errstr,"Invalid version format (version required)");
+ }
+ /* found just an integer */
+ goto version_prescan_finish;
+ }
+ else if ( d == s ) {
+ /* didn't find either integer or period */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+ else if (*d == '_') {
+ /* underscore can't come after integer part */
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ else if (isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ else {
+ /* anything else after integer part is just invalid data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ /* scan the fractional part after the decimal point*/
+
+ if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
+ /* strict or lax-but-not-the-end */
+ BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT(*d)) {
+ d++; j++;
+ if (*d == '.' && isDIGIT(d[-1])) {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ d = (char *)s; /* start all over again */
+ qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT(d[1]) ) {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ width = j;
+ d++;
+ alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE(*d))
+ d++;
+
+ if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
+ /* trailing non-numeric data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (sqv)
+ *sqv = qv;
+ if (swidth)
+ *swidth = width;
+ if (ssaw_decimal)
+ *ssaw_decimal = saw_decimal;
+ if (salpha)
+ *salpha = alpha;
+ return d;
+}
+
+/*
+=for apidoc scan_version
+
+Returns a pointer to the next character after the parsed
+version string, as well as upgrading the passed in SV to
+an RV.
+
+Function must be called with an already existing SV like
+
+ sv = newSV(0);
+ s = scan_version(s, SV *sv, bool qv);
+
+Performs some preprocessing to the string to ensure that
+it has the correct characteristics of a version. Flags the
+object if it contains an underscore (which denotes this
+is an alpha version). The boolean qv denotes that the version
+should be interpreted as if it had multiple decimals, even if
+it doesn't.
+
+=cut
+*/
+
+const char *
+#if VUTIL_REPLACE_CORE
+Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
+#else
+Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
+#endif
+{
+ const char *start = s;
+ const char *pos;
+ const char *last;
+ const char *errstr = NULL;
+ int saw_decimal = 0;
+ int width = 3;
+ bool alpha = FALSE;
+ bool vinf = FALSE;
+ AV * av;
+ SV * hv;
+
+ PERL_ARGS_ASSERT_SCAN_VERSION;
+
+ while (isSPACE(*s)) /* leading whitespace is OK */
+ s++;
+
+ 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);
+ Perl_croak(aTHX_ "%s", errstr);
+ }
+ }
+
+ start = s;
+ if (*s == 'v')
+ s++;
+ pos = s;
+
+ /* Now that we are through the prescan, start creating the object */
+ av = newAV();
+ hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+ (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+
+ if ( qv )
+ (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
+ if ( alpha )
+ (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
+ if ( !qv && width < 3 )
+ (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+
+ while (isDIGIT(*pos))
+ pos++;
+ if (!isALPHA(*pos)) {
+ I32 rev;
+
+ for (;;) {
+ rev = 0;
+ {
+ /* this is atoi() that delimits on underscores */
+ const char *end = pos;
+ I32 mult = 1;
+ I32 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_decimal == 1 ) {
+ mult *= 100;
+ while ( s < end ) {
+ orev = rev;
+ rev += (*s - '0') * mult;
+ mult /= 10;
+ if ( (PERL_ABS(orev) > PERL_ABS(rev))
+ || (PERL_ABS(rev) > VERSION_MAX )) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version %d",VERSION_MAX);
+ s = end - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
+ s++;
+ if ( *s == '_' )
+ s++;
+ }
+ }
+ else {
+ while (--end >= s) {
+ orev = rev;
+ rev += (*end - '0') * mult;
+ mult *= 10;
+ if ( (PERL_ABS(orev) > PERL_ABS(rev))
+ || (PERL_ABS(rev) > VERSION_MAX )) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version");
+ end = s - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
+ }
+ }
+ }
+
+ /* Append revision */
+ av_push(av, newSViv(rev));
+ if ( vinf ) {
+ s = last;
+ break;
+ }
+ else if ( *pos == '.' )
+ s = ++pos;
+ else if ( *pos == '_' && isDIGIT(pos[1]) )
+ s = ++pos;
+ else if ( *pos == ',' && isDIGIT(pos[1]) )
+ s = ++pos;
+ else if ( isDIGIT(*pos) )
+ s = pos;
+ else {
+ s = pos;
+ break;
+ }
+ if ( qv ) {
+ while ( isDIGIT(*pos) )
+ pos++;
+ }
+ else {
+ int digits = 0;
+ while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
+ if ( *pos != '_' )
+ digits++;
+ pos++;
+ }
+ }
+ }
+ }
+ if ( qv ) { /* quoted versions always get at least three terms*/
+ SSize_t len = av_len(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:
+ gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
+ for ( len = 2 - len; len > 0; len-- )
+ av_push(MUTABLE_AV(sv), newSViv(0));
+ */
+ len = 2 - len;
+ while (len-- > 0)
+ av_push(av, newSViv(0));
+ }
+
+ /* need to save off the current version string for later */
+ if ( vinf ) {
+ SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+ (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+ (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
+ }
+ else if ( s > start ) {
+ SV * orig = newSVpvn(start,s-start);
+ if ( qv && saw_decimal == 1 && *start != 'v' ) {
+ /* need to insert a v to be consistent */
+ sv_insert(orig, 0, 0, "v", 1);
+ }
+ (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+ }
+ else {
+ (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
+ av_push(av, newSViv(0));
+ }
+
+ /* And finally, store the AV in the hash */
+ (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") ) {
+ s += 5;
+ }
+
+ return s;
+}
+
+/*
+=for apidoc new_version
+
+Returns a new version object based on the passed in SV:
+
+ SV *sv = new_version(SV *ver);
+
+Does not alter the passed in ver SV. See "upg_version" if you
+want to upgrade the SV.
+
+=cut
+*/
+
+SV *
+#if VUTIL_REPLACE_CORE
+Perl_new_version2(pTHX_ SV *ver)
+#else
+Perl_new_version(pTHX_ SV *ver)
+#endif
+{
+ dVAR;
+ SV * const rv = newSV(0);
+ PERL_ARGS_ASSERT_NEW_VERSION;
+ if ( ISA_CLASS_OBJ(ver,"version") ) /* can just copy directly */
+ {
+ SSize_t key;
+ AV * const av = newAV();
+ AV *sav;
+ /* This will get reblessed later if a derived class*/
+ SV * const hv = newSVrv(rv, "version");
+ (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+
+ if ( SvROK(ver) )
+ ver = SvRV(ver);
+
+ /* Begin copying all of the elements */
+ if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+ (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
+
+ 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));
+ }
+
+ 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));
+ }
+
+ 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));
+ av_push(av, newSViv(rev));
+ }
+
+ (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
+ return rv;
+ }
+#ifdef SvVOK
+ {
+ 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);
+ 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
+ SvSetSV_nosteal(rv, ver); /* make a duplicate */
+#ifdef SvVOK
+ }
+ }
+#endif
+ return UPG_VERSION(rv, FALSE);
+}
+
+/*
+=for apidoc upg_version
+
+In-place upgrade of the supplied SV to a version object.
+
+ SV *sv = upg_version(SV *sv, bool qv);
+
+Returns a pointer to the upgraded SV. Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
+
+=cut
+*/
+
+SV *
+#if VUTIL_REPLACE_CORE
+Perl_upg_version2(pTHX_ SV *ver, bool qv)
+#else
+Perl_upg_version(pTHX_ SV *ver, bool qv)
+#endif
+{
+ const char *version, *s;
+#ifdef SvVOK
+ const MAGIC *mg;
+#endif
+
+ PERL_ARGS_ASSERT_UPG_VERSION;
+
+ if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
+ {
+ STRLEN len;
+
+ /* may get too much accuracy */
+ 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
+ if (sv) {
+ 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
+ while (buf[len-1] == '0' && len > 0) len--;
+ if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
+ version = savepvn(buf, len);
+ 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 );
+ qv = TRUE;
+ }
+#endif
+ else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
+ || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
+ /* out of bounds [unsigned] integer */
+ STRLEN len;
+ char tbuf[64];
+ len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
+ version = savepvn(tbuf, len);
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version %d",VERSION_MAX);
+ }
+ else if ( SvUOK(ver) || SvIOK(ver) ) {
+ version = savesvpv(ver);
+ }
+ else if ( SvPOK(ver) )/* must be a string or something like a string */
+ {
+ STRLEN len;
+ version = savepvn(SvPV(ver,len), SvCUR(ver));
+#ifndef SvVOK
+# if PERL_VERSION > 5
+ /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
+ /* may be a v-string */
+ char *testv = (char *)version;
+ STRLEN tlen = len;
+ for (tlen=0; tlen < len; tlen++, testv++) {
+ /* if one of the characters is non-text assume v-string */
+ if (testv[0] < ' ') {
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_decimal = 0;
+ sv_setpvf(nsv,"v%vd",ver);
+ pos = nver = savepv(SvPV_nolen(nsv));
+
+ /* scan the resulting formatted string */
+ pos++; /* skip the leading 'v' */
+ while ( *pos == '.' || isDIGIT(*pos) ) {
+ if ( *pos == '.' )
+ saw_decimal++ ;
+ pos++;
+ }
+
+ /* is definitely a v-string */
+ if ( saw_decimal >= 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ break;
+ }
+ }
+ }
+# endif
+#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);
+ return ver;
+}
+
+/*
+=for apidoc vverify
+
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV). If
+the structure is valid, it returns the HV. If the structure is invalid,
+it returns NULL.
+
+ SV *hv = vverify(sv);
+
+Note that it only confirms the bare minimum structure (so as not to get
+confused by derived classes which may contain additional hash entries):
+
+=over 4
+
+=item * The SV is an HV or a reference to an HV
+
+=item * The hash contains a "version" key
+
+=item * The "version" key has a reference to an AV as its value
+
+=back
+
+=cut
+*/
+
+SV *
+#if VUTIL_REPLACE_CORE
+Perl_vverify2(pTHX_ SV *vs)
+#else
+Perl_vverify(pTHX_ SV *vs)
+#endif
+{
+ SV *sv;
+
+ PERL_ARGS_ASSERT_VVERIFY;
+
+ if ( SvROK(vs) )
+ vs = SvRV(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)))
+ && SvTYPE(sv) == SVt_PVAV )
+ return vs;
+ else
+ return NULL;
+}
+
+/*
+=for apidoc vnumify
+
+Accepts a version object and returns the normalized floating
+point representation. Call like:
+
+ sv = vnumify(rv);
+
+NOTE: you can pass either the object directly or the SV
+contained within the RV.
+
+The SV returned has a refcount of 1.
+
+=cut
+*/
+
+SV *
+#if VUTIL_REPLACE_CORE
+Perl_vnumify2(pTHX_ SV *vs)
+#else
+Perl_vnumify(pTHX_ SV *vs)
+#endif
+{
+ SSize_t i, len;
+ I32 digit;
+ int width;
+ bool alpha = FALSE;
+ SV *sv;
+ AV *av;
+
+ PERL_ARGS_ASSERT_VNUMIFY;
+
+ /* extract the HV from the object */
+ vs = VVERIFY(vs);
+ if ( ! vs )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ /* 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;
+
+
+ /* attempt to retrieve the version array */
+ if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
+ return newSVpvs("0");
+ }
+
+ len = av_len(av);
+ if ( len == -1 )
+ {
+ return newSVpvs("0");
+ }
+
+ digit = SvIV(*av_fetch(av, 0, 0));
+ sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
+ for ( i = 1 ; i < len ; i++ )
+ {
+ digit = SvIV(*av_fetch(av, i, 0));
+ if ( width < 3 ) {
+ const int denom = (width == 2 ? 10 : 100);
+ const div_t term = div((int)PERL_ABS(digit),denom);
+ Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
+ }
+ else {
+ Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
+ }
+ }
+
+ if ( len > 0 )
+ {
+ digit = SvIV(*av_fetch(av, len, 0));
+ if ( alpha && width == 3 ) /* alpha version */
+ sv_catpvs(sv,"_");
+ Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
+ }
+ else /* len == 0 */
+ {
+ sv_catpvs(sv, "000");
+ }
+ return sv;
+}
+
+/*
+=for apidoc vnormal
+
+Accepts a version object and returns the normalized string
+representation. Call like:
+
+ sv = vnormal(rv);
+
+NOTE: you can pass either the object directly or the SV
+contained within the RV.
+
+The SV returned has a refcount of 1.
+
+=cut
+*/
+
+SV *
+#if VUTIL_REPLACE_CORE
+Perl_vnormal2(pTHX_ SV *vs)
+#else
+Perl_vnormal(pTHX_ SV *vs)
+#endif
+{
+ I32 i, len, digit;
+ bool alpha = FALSE;
+ SV *sv;
+ AV *av;
+
+ PERL_ARGS_ASSERT_VNORMAL;
+
+ /* extract the HV from the object */
+ vs = VVERIFY(vs);
+ if ( ! vs )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
+ alpha = TRUE;
+ av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
+
+ len = av_len(av);
+ if ( len == -1 )
+ {
+ return newSVpvs("");
+ }
+ digit = SvIV(*av_fetch(av, 0, 0));
+ sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
+ for ( i = 1 ; i < len ; i++ ) {
+ digit = SvIV(*av_fetch(av, i, 0));
+ Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+ }
+
+ if ( len > 0 )
+ {
+ /* handle last digit specially */
+ digit = SvIV(*av_fetch(av, len, 0));
+ if ( alpha )
+ Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
+ else
+ Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+ }
+
+ if ( len <= 2 ) { /* short version, must be at least three */
+ for ( len = 2 - len; len != 0; len-- )
+ sv_catpvs(sv,".0");
+ }
+ return sv;
+}
+
+/*
+=for apidoc vstringify
+
+In order to maintain maximum compatibility with earlier versions
+of Perl, this function will return either the floating point
+notation or the multiple dotted notation, depending on whether
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
+
+=cut
+*/
+
+SV *
+#if VUTIL_REPLACE_CORE
+Perl_vstringify2(pTHX_ SV *vs)
+#else
+Perl_vstringify(pTHX_ SV *vs)
+#endif
+{
+ PERL_ARGS_ASSERT_VSTRINGIFY;
+
+ /* extract the HV from the object */
+ vs = VVERIFY(vs);
+ if ( ! vs )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
+ SV *pv;
+ pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+ if ( SvPOK(pv) )
+ return newSVsv(pv);
+ else
+ return &PL_sv_undef;
+ }
+ else {
+ if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+ return VNORMAL(vs);
+ else
+ return VNUMIFY(vs);
+ }
+}
+
+/*
+=for apidoc vcmp
+
+Version object aware cmp. Both operands must already have been
+converted into version objects.
+
+=cut
+*/
+
+int
+#if VUTIL_REPLACE_CORE
+Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
+#else
+Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
+#endif
+{
+ SSize_t i,l,m,r;
+ I32 retval;
+ bool lalpha = FALSE;
+ bool ralpha = FALSE;
+ I32 left = 0;
+ I32 right = 0;
+ AV *lav, *rav;
+
+ PERL_ARGS_ASSERT_VCMP;
+
+ /* extract the HVs from the objects */
+ lhv = VVERIFY(lhv);
+ rhv = VVERIFY(rhv);
+ if ( ! ( lhv && rhv ) )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ /* get the left hand term */
+ lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
+ if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
+ lalpha = TRUE;
+
+ /* and the right hand term */
+ rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
+ if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
+ ralpha = TRUE;
+
+ l = av_len(lav);
+ r = av_len(rav);
+ m = l < r ? l : r;
+ retval = 0;
+ i = 0;
+ while ( i <= m && retval == 0 )
+ {
+ left = SvIV(*av_fetch(lav,i,0));
+ right = SvIV(*av_fetch(rav,i,0));
+ if ( left < right )
+ retval = -1;
+ if ( left > right )
+ retval = +1;
+ i++;
+ }
+
+ /* tiebreaker for alpha with identical terms */
+ if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
+ {
+ if ( lalpha && !ralpha )
+ {
+ retval = -1;
+ }
+ else if ( ralpha && !lalpha)
+ {
+ retval = +1;
+ }
+ }
+
+ if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
+ {
+ if ( l < r )
+ {
+ while ( i <= r && retval == 0 )
+ {
+ if ( SvIV(*av_fetch(rav,i,0)) != 0 )
+ retval = -1; /* not a match after all */
+ i++;
+ }
+ }
+ else
+ {
+ while ( i <= l && retval == 0 )
+ {
+ if ( SvIV(*av_fetch(lav,i,0)) != 0 )
+ retval = +1; /* not a match after all */
+ i++;
+ }
+ }
+ }
+ return retval;
+}
diff --git a/vutil.h b/vutil.h
new file mode 100644
index 0000000000..f86631d654
--- /dev/null
+++ b/vutil.h
@@ -0,0 +1,179 @@
+/* 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;
+ * e.g.:
+ *
+ * const SV *sv = ...;
+ * AV *av1 = (AV*)sv; <== BAD: the const has been silently cast away
+ * AV *av2 = MUTABLE_AV(sv); <== GOOD: it may warn
+ */
+
+#ifndef MUTABLE_PTR
+# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
+# else
+# define MUTABLE_PTR(p) ((void *) (p))
+# endif
+
+# define MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p))
+# define MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p))
+# define MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p))
+# define MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p))
+# define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p))
+# define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
+#endif
+
+#ifndef SvPVx_nolen_const
+# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define SvPVx_nolen_const(sv) ({SV *_sv = (sv); SvPV_nolen_const(_sv); })
+# else
+# define SvPVx_nolen_const(sv) (SvPV_nolen_const(sv))
+# endif
+#endif
+
+#ifndef PERL_ARGS_ASSERT_CK_WARNER
+static void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...);
+
+# ifdef vwarner
+static
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+ va_list args;
+
+ PERL_UNUSED_ARG(err);
+ if (ckWARN(err)) {
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
+ }
+}
+# else
+/* yes this replicates my_warner */
+static
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+ SV *sv;
+ va_list args;
+
+ PERL_UNUSED_ARG(err);
+
+ va_start(args, pat);
+ sv = vnewSVpvf(pat, &args);
+ va_end(args);
+ sv_2mortal(sv);
+ warn("%s", SvPV_nolen(sv));
+}
+# endif
+#endif
+
+#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
+#define PERL_DECIMAL_VERSION \
+ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
+#define PERL_VERSION_LT(r,v,s) \
+ (PERL_DECIMAL_VERSION < PERL_VERSION_DECIMAL(r,v,s))
+#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_GE(5,9,0) && !defined(PERL_CORE)
+
+# define VUTIL_REPLACE_CORE 1
+
+const char * Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv);
+SV * Perl_new_version2(pTHX_ SV *ver);
+SV * Perl_upg_version2(pTHX_ SV *sv, bool qv);
+SV * Perl_vstringify2(pTHX_ SV *vs);
+SV * Perl_vverify2(pTHX_ SV *vs);
+SV * Perl_vnumify2(pTHX_ SV *vs);
+SV * Perl_vnormal2(pTHX_ SV *vs);
+SV * Perl_vstringify2(pTHX_ SV *vs);
+int Perl_vcmp2(pTHX_ SV *lsv, SV *rsv);
+const char * Perl_prescan_version2(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
+
+# define SCAN_VERSION(a,b,c) Perl_scan_version2(aTHX_ a,b,c)
+# define NEW_VERSION(a) Perl_new_version2(aTHX_ a)
+# define UPG_VERSION(a,b) Perl_upg_version2(aTHX_ a, b)
+# define VSTRINGIFY(a) Perl_vstringify2(aTHX_ a)
+# define VVERIFY(a) Perl_vverify2(aTHX_ a)
+# define VNUMIFY(a) Perl_vnumify2(aTHX_ a)
+# 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)
+# define is_LAX_VERSION(a,b) \
+ (a != Perl_prescan_version2(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
+# define is_STRICT_VERSION(a,b) \
+ (a != Perl_prescan_version2(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
+
+#else
+
+const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv);
+SV * Perl_new_version(pTHX_ SV *ver);
+SV * Perl_upg_version(pTHX_ SV *sv, bool qv);
+SV * Perl_vverify(pTHX_ SV *vs);
+SV * Perl_vnumify(pTHX_ SV *vs);
+SV * Perl_vnormal(pTHX_ SV *vs);
+SV * Perl_vstringify(pTHX_ SV *vs);
+int Perl_vcmp(pTHX_ SV *lsv, SV *rsv);
+const char * Perl_prescan_version(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
+
+# define SCAN_VERSION(a,b,c) Perl_scan_version(aTHX_ a,b,c)
+# define NEW_VERSION(a) Perl_new_version(aTHX_ a)
+# define UPG_VERSION(a,b) Perl_upg_version(aTHX_ a, b)
+# define VSTRINGIFY(a) Perl_vstringify(aTHX_ a)
+# define VVERIFY(a) Perl_vverify(aTHX_ a)
+# define VNUMIFY(a) Perl_vnumify(aTHX_ a)
+# define VNORMAL(a) Perl_vnormal(aTHX_ a)
+# 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)
+# ifndef is_LAX_VERSION
+# define is_LAX_VERSION(a,b) \
+ (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
+# 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
+
+#if PERL_VERSION_LT(5,11,4)
+# define BADVERSION(a,b,c) \
+ if (b) { \
+ *b = c; \
+ } \
+ return a;
+
+# define PERL_ARGS_ASSERT_PRESCAN_VERSION \
+ assert(s); assert(sqv); assert(ssaw_decimal);\
+ assert(swidth); assert(salpha);
+
+# define PERL_ARGS_ASSERT_SCAN_VERSION \
+ assert(s); assert(rv)
+# define PERL_ARGS_ASSERT_NEW_VERSION \
+ assert(ver)
+# define PERL_ARGS_ASSERT_UPG_VERSION \
+ assert(ver)
+# define PERL_ARGS_ASSERT_VVERIFY \
+ assert(vs)
+# define PERL_ARGS_ASSERT_VNUMIFY \
+ assert(vs)
+# define PERL_ARGS_ASSERT_VNORMAL \
+ assert(vs)
+# define PERL_ARGS_ASSERT_VSTRINGIFY \
+ assert(vs)
+# define PERL_ARGS_ASSERT_VCMP \
+ assert(lhv); assert(rhv)
+# define PERL_ARGS_ASSERT_CK_WARNER \
+ assert(pat)
+#endif
diff --git a/vxs.inc b/vxs.inc
new file mode 100644
index 0000000000..e297c387a2
--- /dev/null
+++ b/vxs.inc
@@ -0,0 +1,458 @@
+/* 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
+#else
+# define VXS_CLASS "version::vxs"
+# define VXSp(name) VXS_##name
+#endif
+#define VXS(name) XS(VXSp(name))
+
+#ifdef VXS_XSUB_DETAILS
+# ifdef PERL_CORE
+ {"UNIVERSAL::VERSION", VXSp(universal_version), NULL},
+# endif
+ {VXS_CLASS "::_VERSION", VXSp(universal_version), NULL},
+ {VXS_CLASS "::()", VXSp(version_noop), NULL},
+ {VXS_CLASS "::new", VXSp(version_new), NULL},
+ {VXS_CLASS "::parse", VXSp(version_new), NULL},
+ {VXS_CLASS "::(\"\"", VXSp(version_stringify), NULL},
+ {VXS_CLASS "::stringify", VXSp(version_stringify), NULL},
+ {VXS_CLASS "::(0+", VXSp(version_numify), NULL},
+ {VXS_CLASS "::numify", VXSp(version_numify), NULL},
+ {VXS_CLASS "::normal", VXSp(version_normal), NULL},
+ {VXS_CLASS "::(cmp", VXSp(version_vcmp), NULL},
+ {VXS_CLASS "::(<=>", VXSp(version_vcmp), NULL},
+# ifdef PERL_CORE
+ {VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
+# else
+ {VXS_CLASS "::VCMP", VXS_version_vcmp, NULL},
+# endif
+ {VXS_CLASS "::(bool", VXSp(version_boolean), NULL},
+ {VXS_CLASS "::boolean", VXSp(version_boolean), NULL},
+ {VXS_CLASS "::(+", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(-", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(*", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(/", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(+=", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(-=", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(*=", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(/=", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(abs", VXSp(version_noop), NULL},
+ {VXS_CLASS "::(nomethod", VXSp(version_noop), NULL},
+ {VXS_CLASS "::noop", VXSp(version_noop), NULL},
+ {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), NULL},
+ {VXS_CLASS "::qv", VXSp(version_qv), NULL},
+ {VXS_CLASS "::declare", VXSp(version_qv), NULL},
+ {VXS_CLASS "::is_qv", VXSp(version_is_qv), NULL},
+#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 *ret;
+ 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_CLASS_OBJ(sv, "version"))
+ 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 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_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_ "%"HEKf" version %"SVf" required--"
+ "this is only version %"SVf"", HEKfARG(HvNAME_HEK(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);
+}
+
+VXS(version_new)
+{
+ dVAR;
+ dXSARGS;
+ PERL_UNUSED_VAR(cv);
+ SV *vs = items ? ST(1) : &PL_sv_undef;
+ SV *rv;
+ const char * classname = "";
+ STRLEN len;
+ U32 flags = 0;
+ SP -= items;
+
+ if (items > 3 || items == 0)
+ Perl_croak(aTHX_ "Usage: version::new(class, version)");
+
+ /* Just in case this is something like a tied hash */
+ SvGETMAGIC(vs);
+
+ 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();
+#if PERL_VERSION == 5
+ sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
+#else
+ Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
+#endif
+ }
+ if ( sv_isobject(ST(0)) ) {
+ /* get the class if called as an object method */
+ const HV * stash = SvSTASH(SvRV(ST(0)));
+ classname = HvNAME_get(stash);
+ len = HvNAMELEN_get(stash);
+#ifdef HvNAMEUTF8
+ flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+#endif
+ }
+ else {
+ classname = SvPV(ST(0), len);
+ flags = SvUTF8(ST(0));
+ }
+
+ 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
+
+ mPUSHs(rv);
+ PUTBACK;
+ return;
+}
+
+#define VTYPECHECK(var, val, varname) \
+ STMT_START { \
+ if (ISA_CLASS_OBJ(val, "version")) { \
+ (var) = SvRV(val); \
+ } \
+ else \
+ Perl_croak(aTHX_ 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");
+
+ mPUSHs(VSTRINGIFY(lobj));
+
+ PUTBACK;
+ return;
+ }
+}
+
+VXS(version_numify)
+{
+ dVAR;
+ dXSARGS;
+ if (items < 1)
+ croak_xs_usage(cv, "lobj, ...");
+ SP -= items;
+ {
+ SV * lobj;
+ VTYPECHECK(lobj, ST(0), "lobj");
+ mPUSHs(VNUMIFY(lobj));
+ PUTBACK;
+ return;
+ }
+}
+
+VXS(version_normal)
+{
+ dVAR;
+ dXSARGS;
+ if (items != 1)
+ croak_xs_usage(cv, "ver");
+ SP -= items;
+ {
+ SV * ver;
+ VTYPECHECK(ver, ST(0), "ver");
+
+ mPUSHs(VNORMAL(ver));
+
+ PUTBACK;
+ return;
+ }
+}
+
+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_CLASS_OBJ(robj, "version") )
+ {
+ robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
+ sv_2mortal(robj);
+ }
+ rvs = SvRV(robj);
+
+ if ( swap )
+ {
+ rs = newSViv(VCMP(rvs,lobj));
+ }
+ else
+ {
+ rs = newSViv(VCMP(lobj,rvs));
+ }
+
+ mPUSHs(rs);
+ }
+
+ PUTBACK;
+ return;
+ }
+}
+
+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"))
+ ))
+ )
+ );
+ mPUSHs(rs);
+ PUTBACK;
+ return;
+ }
+}
+
+VXS(version_noop)
+{
+ dVAR;
+ dXSARGS;
+ if (items < 1)
+ croak_xs_usage(cv, "lobj, ...");
+ if (ISA_CLASS_OBJ(ST(0), "version"))
+ Perl_croak(aTHX_ "operation not supported with version object");
+ else
+ Perl_croak(aTHX_ "lobj is not of type version");
+ XSRETURN_EMPTY;
+}
+
+VXS(version_is_alpha)
+{
+ dVAR;
+ dXSARGS;
+ if (items != 1)
+ croak_xs_usage(cv, "lobj");
+ SP -= items;
+ {
+ SV *lobj;
+ VTYPECHECK(lobj, ST(0), "lobj");
+ if ( hv_exists(MUTABLE_HV(lobj), "alpha", 5 ) )
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+ PUTBACK;
+ return;
+ }
+}
+
+VXS(version_qv)
+{
+ dVAR;
+ dXSARGS;
+ PERL_UNUSED_ARG(cv);
+ SP -= items;
+ {
+ SV * ver = ST(0);
+ SV * rv;
+ STRLEN len = 0;
+ const char * classname = "";
+ U32 flags = 0;
+ if ( items == 2 ) {
+ SvGETMAGIC(ST(1));
+ if (SvOK(ST(1))) {
+ ver = ST(1);
+ }
+ else {
+ Perl_croak(aTHX_ "Invalid version format (version required)");
+ }
+ if ( sv_isobject(ST(0)) ) { /* class called as an object method */
+ const HV * stash = SvSTASH(SvRV(ST(0)));
+ classname = HvNAME_get(stash);
+ len = HvNAMELEN_get(stash);
+#ifdef HvNAMEUTF8
+ flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+#endif
+ }
+ else {
+ classname = SvPV(ST(0), len);
+ flags = SvUTF8(ST(0));
+ }
+ }
+ 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)
+{
+ dVAR;
+ dXSARGS;
+ if (items != 1)
+ croak_xs_usage(cv, "lobj");
+ SP -= items;
+ {
+ SV *lobj;
+ VTYPECHECK(lobj, ST(0), "lobj");
+ if ( hv_exists(MUTABLE_HV(lobj), "qv", 2 ) )
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+ PUTBACK;
+ return;
+ }
+}
+
+#endif