[p5sagit/Module-Metadata.git] / lib / Module / Metadata / Version.pm

package Module::Metadata::Version;
use strict;

# stolen from Module::Build::Version - this is perl licensed code,
# copyright them.

use vars qw($VERSION);
$VERSION = 0.77;

eval "use version $VERSION";
if ($@) { # can't locate version files, use our own

    # Avoid redefined warnings if an old version.pm was available
    delete $version::{$_} foreach keys %version::;

    # first we get the stub version module
    my $version;
    while (<DATA>) {
	s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
	$version .= $_ if $_;
	last if /^1;$/;
    }

    # and now get the current version::vpp code
    my $vpp;
    while (<DATA>) {
	s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
	$vpp .= $_ if $_;
	last if /^1;$/;
    }

    # but we eval them in reverse order since version depends on
    # version::vpp to already exist
    eval $vpp; die $@ if $@;
    $INC{'version/vpp.pm'} = 'inside Module::Metadata::Version';
    eval $version; die $@ if $@;
    $INC{'version.pm'} = 'inside Module::Metadata::Version';
}

# now we can safely subclass version, installed or not
use vars qw(@ISA);
@ISA = qw(version);

1;

=head1 NAME

Module::Metadata::Version - inlined version.pm fallback for Module::Metadata

=head1 DESCRIPTION

This module either loads version.pm if available, or if not slurps its own
private copy of version::vpp into memory as a fallback, then makes itself
a subclass of whichever it found.

This is a horrible hack. But so is version.pm.

=head1 AUTHOR

Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>

Documented by Matt S Trout (mst) <mst@shadowcat.co.uk>

=head1 COPYRIGHT

Copyright (c) 2001-2006 Ken Williams.  All rights reserved.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

perl(1), L<Module::Build::ModuleInfo>(3)

=cut

__DATA__
# stub version module to make everything else happy
package version;

use 5.005_04;
use strict;

use vars qw(@ISA $VERSION $CLASS *declare *qv);

$VERSION = 0.77;

$CLASS = 'version';

push @ISA, "version::vpp";
local $^W;
*version::qv = \&version::vpp::qv;
*version::declare = \&version::vpp::declare;
*version::_VERSION = \&version::vpp::_VERSION;
if ($] > 5.009001 && $] <= 5.010000) {
    no strict 'refs';
    *{'version::stringify'} = \*version::vpp::stringify;
    *{'version::(""'} = \*version::vpp::stringify;
    *{'version::new'} = \*version::vpp::new;
}

# Preloaded methods go here.
sub import {
    no strict 'refs';
    my ($class) = shift;

    # Set up any derived class
    unless ($class eq 'version') {
	local $^W;
	*{$class.'::declare'} =  \&version::declare;
	*{$class.'::qv'} = \&version::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 = \&version::_VERSION;
    }

    if (exists($args{'VERSION'})) {
	*{$callpkg."::VERSION"} = \&version::_VERSION;
    }
}

1;

# replace everything from here to the end with the current version/vpp.pm
package version::vpp;
use strict;

use POSIX qw/locale_h/;
use locale;
use vars qw ($VERSION @ISA @REGEXS);
$VERSION = '0.77';
$VERSION = eval $VERSION;

push @REGEXS, qr/
	^v?	# optional leading 'v'
	(\d*)	# major revision not required
	\.	# requires at least one decimal
	(?:(\d+)\.?){1,}
	/x;

use overload (
    '""'       => \&stringify,
    '0+'       => \&numify,
    'cmp'      => \&vcmp,
    '<=>'      => \&vcmp,
    'bool'     => \&vbool,
    'nomethod' => \&vnoop,
);

my $VERSION_MAX = 0x7FFFFFFF;

eval "use warnings";
if ($@) {
    eval '
	package warnings;
	sub enabled {return $^W;}
	1;
    ';
}

sub new
{
	my ($class, $value) = @_;
	my $self = bless ({}, ref ($class) || $class);

	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 = 'v'.$_[2];
	}

	$value = _un_vstring($value);

	# exponential notation
	if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
	    $value = sprintf("%.9f",$value);
	    $value =~ s/(0+)$//; # trim trailing zeros
	}

	# This is not very efficient, but it is morally equivalent
	# to the XS code (as that is the reference implementation).
	# See vutil/vutil.c for details
	my $qv = 0;
	my $alpha = 0;
	my $width = 3;
	my $saw_period = 0;
	my $vinf = 0;
	my ($start, $last, $pos, $s);
	$s = 0;

	while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
	    $s++;
	}

	if (substr($value,$s,1) eq 'v') {
	    $s++;    # get past 'v'
	    $qv = 1; # force quoted version processing
	}

	$start = $last = $pos = $s;

	# pre-scan the input string to check for decimals/underbars
	while ( substr($value,$pos,1) =~ /[._\d,]/ ) {
	    if ( substr($value,$pos,1) eq '.' ) {
		if ($alpha) {
		    Carp::croak("Invalid version format ".
		      "(underscores before decimal)");
		}
		$saw_period++;
		$last = $pos;
	    }
	    elsif ( substr($value,$pos,1) eq '_' ) {
		if ($alpha) {
		    require Carp;
		    Carp::croak("Invalid version format ".
			"(multiple underscores)");
		}
		$alpha = 1;
		$width = $pos - $last - 1; # natural width of sub-version
	    }
	    elsif ( substr($value,$pos,1) eq ','
		    and substr($value,$pos+1,1) =~ /[0-9]/ ) {
		# looks like an unhandled locale
		$saw_period++;
		$last = $pos;
	    }
	    $pos++;
	}

	if ( $alpha && !$saw_period ) {
	    require Carp;
	    Carp::croak("Invalid version format ".
		"(alpha without decimal)");
	}

	if ( $alpha && $saw_period && $width == 0 ) {
	    require Carp;
	    Carp::croak("Invalid version format ".
		"(misplaced _ in number)");
	}

	if ( $saw_period > 1 ) {
	    $qv = 1; # force quoted version processing
	}

	$last = $pos;
	$pos = $s;

	if ( $qv ) {
	    $self->{qv} = 1;
	}

	if ( $alpha ) {
	    $self->{alpha} = 1;
	}

	if ( !$qv && $width < 3 ) {
	    $self->{width} = $width;
	}

	while ( substr($value,$pos,1) =~ /\d/ ) {
	    $pos++;
	}

	if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
	    my $rev;

	    while (1) {
		$rev = 0;
		{

		    # this is atoi() that delimits on underscores
		    my $end = $pos;
		    my $mult = 1;
		    my $orev;

		    # the following if() will only be true after the decimal
		    # point of a version originally created with a bare
		    # floating point number, i.e. not quoted in any way
		    if ( !$qv && $s > $start && $saw_period == 1 ) {
			$mult *= 100;
			while ( $s < $end ) {
			    $orev = $rev;
			    $rev += substr($value,$s,1) * $mult;
			    $mult /= 10;
			    if (   abs($orev) > abs($rev)
				|| abs($rev) > abs($VERSION_MAX) ) {
				if ( warnings::enabled("overflow") ) {
				    require Carp;
				    Carp::carp("Integer overflow in version");
				}
				$s = $end - 1;
				$rev = $VERSION_MAX;
			    }
			    $s++;
			    if ( substr($value,$s,1) eq '_' ) {
				$s++;
			    }
			}
		    }
		    else {
			while (--$end >= $s) {
			    $orev = $rev;
			    $rev += substr($value,$end,1) * $mult;
			    $mult *= 10;
			    if (   abs($orev) > abs($rev)
				|| abs($rev) > abs($VERSION_MAX) ) {
				if ( warnings::enabled("overflow") ) {
				    require Carp;
				    Carp::carp("Integer overflow in version");
				}
				$end = $s - 1;
				$rev = $VERSION_MAX;
			    }
			}
		    }
		}

		# Append revision
		push @{$self->{version}}, $rev;
		if ( substr($value,$pos,1) eq '.'
		    && substr($value,$pos+1,1) =~ /\d/ ) {
		    $s = ++$pos;
		}
		elsif ( substr($value,$pos,1) eq '_'
		    && substr($value,$pos+1,1) =~ /\d/ ) {
		    $s = ++$pos;
		}
		elsif ( substr($value,$pos,1) eq ','
		    && substr($value,$pos+1,1) =~ /\d/ ) {
		    $s = ++$pos;
		}
		elsif ( substr($value,$pos,1) =~ /\d/ ) {
		    $s = $pos;
		}
		else {
		    $s = $pos;
		    last;
		}
		if ( $qv ) {
		    while ( substr($value,$pos,1) =~ /\d/ ) {
			$pos++;
		    }
		}
		else {
		    my $digits = 0;
		    while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
			if ( substr($value,$pos,1) ne '_' ) {
			    $digits++;
			}
			$pos++;
		    }
		}
	    }
	}
	if ( $qv ) { # quoted versions always get at least three terms
	    my $len = scalar @{$self->{version}};
	    $len = 3 - $len;
	    while ($len-- > 0) {
		push @{$self->{version}}, 0;
	    }
	}

	if ( substr($value,$pos) ) { # any remaining text
	    if ( warnings::enabled("misc") ) {
		require Carp;
		Carp::carp("Version string '$value' contains invalid data; ".
		     "ignoring: '".substr($value,$pos)."'");
	    }
	}

	# cache the original value for use when stringification
	if ( $vinf ) {
	    $self->{vinf} = 1;
	    $self->{original} = 'v.Inf';
	}
	else {
	    $self->{original} = substr($value,0,$pos);
	}

	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 object");
    }
    my $l = $#{$left->{version}};
    my $r = $#{$right->{version}};
    my $m = $l < $r ? $l : $r;
    my $lalpha = $left->is_alpha;
    my $ralpha = $right->is_alpha;
    my $retval = 0;
    my $i = 0;
    while ( $i <= $m && $retval == 0 ) {
	$retval = $left->{version}[$i] <=> $right->{version}[$i];
	$i++;
    }

    # tiebreaker for alpha with identical terms
    if ( $retval == 0
	&& $l == $r
	&& $left->{version}[$m] == $right->{version}[$m]
	&& ( $lalpha || $ralpha ) ) {

	if ( $lalpha && !$ralpha ) {
	    $retval = -1;
	}
	elsif ( $ralpha && !$lalpha) {
	    $retval = +1;
	}
    }

    # possible match except for trailing 0's
    if ( $retval == 0 && $l != $r ) {
	if ( $l < $r ) {
	    while ( $i <= $r && $retval == 0 ) {
		if ( $right->{version}[$i] != 0 ) {
		    $retval = -1; # not a match after all
		}
		$i++;
	    }
	}
	else {
	    while ( $i <= $l && $retval == 0 ) {
		if ( $left->{version}[$i] != 0 ) {
		    $retval = +1; # not a match after all
		}
		$i++;
	    }
	}
    }

    return $retval;
}

sub 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 = 'version';
    if (@_) {
	$class = ref($value) || $value;
	$value = shift;
    }

    $value = _un_vstring($value);
    $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
    my $version = $class->new($value);
    return $version;
}

*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 _un_vstring {
    my $value = shift;
    # may be a v-string
    if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) {
	my $tvalue = sprintf("v%vd",$value);
	if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) {
	    # must be a v-string
	    $value = $tvalue;
	}
    }
    return $value;
}

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
Commit	Line	Data
5ac756c6	1	package Module::Metadata::Version;
	2	use strict;
	3
	4	# stolen from Module::Build::Version - this is perl licensed code,
	5	# copyright them.
	6
	7	use vars qw($VERSION);
	8	$VERSION = 0.77;
	9
	10	eval "use version $VERSION";
	11	if ($@) { # can't locate version files, use our own
	12
	13	# Avoid redefined warnings if an old version.pm was available
	14	delete $version::{$_} foreach keys %version::;
	15
	16	# first we get the stub version module
	17	my $version;
	18	while (<DATA>) {
	19	s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
	20	$version .= $_ if $_;
	21	last if /^1;$/;
	22	}
	23
	24	# and now get the current version::vpp code
	25	my $vpp;
	26	while (<DATA>) {
	27	s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
	28	$vpp .= $_ if $_;
	29	last if /^1;$/;
	30	}
	31
	32	# but we eval them in reverse order since version depends on
	33	# version::vpp to already exist
	34	eval $vpp; die $@ if $@;
	35	$INC{'version/vpp.pm'} = 'inside Module::Metadata::Version';
	36	eval $version; die $@ if $@;
	37	$INC{'version.pm'} = 'inside Module::Metadata::Version';
	38	}
	39
	40	# now we can safely subclass version, installed or not
	41	use vars qw(@ISA);
	42	@ISA = qw(version);
	43
	44	1;
2c11e51d	45
	46	=head1 NAME
	47
	48	Module::Metadata::Version - inlined version.pm fallback for Module::Metadata
	49
	50	=head1 DESCRIPTION
	51
	52	This module either loads version.pm if available, or if not slurps its own
	53	private copy of version::vpp into memory as a fallback, then makes itself
	54	a subclass of whichever it found.
	55
	56	This is a horrible hack. But so is version.pm.
	57
	58	=head1 AUTHOR
	59
	60	Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
	61
	62	Documented by Matt S Trout (mst) <mst@shadowcat.co.uk>
	63
	64	=head1 COPYRIGHT
	65
	66	Copyright (c) 2001-2006 Ken Williams. All rights reserved.
	67
	68	This library is free software; you can redistribute it and/or
	69	modify it under the same terms as Perl itself.
	70
	71	=head1 SEE ALSO
	72
	73	perl(1), L<Module::Build::ModuleInfo>(3)
	74
	75	=cut
	76
5ac756c6	77	__DATA__
	78	# stub version module to make everything else happy
	79	package version;
	80
	81	use 5.005_04;
	82	use strict;
	83
	84	use vars qw(@ISA $VERSION $CLASS declare qv);
	85
	86	$VERSION = 0.77;
	87
	88	$CLASS = 'version';
	89
	90	push @ISA, "version::vpp";
	91	local $^W;
	92	*version::qv = \&version::vpp::qv;
	93	*version::declare = \&version::vpp::declare;
	94	*version::_VERSION = \&version::vpp::_VERSION;
	95	if ($] > 5.009001 && $] <= 5.010000) {
	96	no strict 'refs';
	97	{'version::stringify'} = \version::vpp::stringify;
	98	{'version::(""'} = \version::vpp::stringify;
	99	{'version::new'} = \version::vpp::new;
	100	}
	101
	102	# Preloaded methods go here.
	103	sub import {
	104	no strict 'refs';
	105	my ($class) = shift;
	106
	107	# Set up any derived class
	108	unless ($class eq 'version') {
	109	local $^W;
	110	*{$class.'::declare'} = \&version::declare;
	111	*{$class.'::qv'} = \&version::qv;
	112	}
	113
	114	my %args;
	115	if (@_) { # any remaining terms are arguments
	116	map { $args{$_} = 1 } @_
	117	}
	118	else { # no parameters at all on use line
	119	%args =
	120	(
	121	qv => 1,
	122	'UNIVERSAL::VERSION' => 1,
	123	);
	124	}
	125
	126	my $callpkg = caller();
	127
	128	if (exists($args{declare})) {
	129	*{$callpkg."::declare"} =
	130	sub {return $class->declare(shift) }
	131	unless defined(&{$callpkg.'::declare'});
	132	}
	133
	134	if (exists($args{qv})) {
	135	*{$callpkg."::qv"} =
	136	sub {return $class->qv(shift) }
	137	unless defined(&{"$callpkg\::qv"});
	138	}
	139
	140	if (exists($args{'UNIVERSAL::VERSION'})) {
141	local $^W;
142	*UNIVERSAL::VERSION = \&version::_VERSION;
143	}
144
145	if (exists($args{'VERSION'})) {
146	*{$callpkg."::VERSION"} = \&version::_VERSION;
147	}
148	}
149
150	1;
151
152	# replace everything from here to the end with the current version/vpp.pm
153	package version::vpp;
154	use strict;
155
156	use POSIX qw/locale_h/;
157	use locale;
158	use vars qw ($VERSION @ISA @REGEXS);
159	$VERSION = '0.77';
160	$VERSION = eval $VERSION;
161
162	push @REGEXS, qr/
163	^v? # optional leading 'v'
164	(\d*) # major revision not required
165	\. # requires at least one decimal
166	(?:(\d+)\.?){1,}
167	/x;
168
169	use overload (
170	'""' => \&stringify,
171	'0+' => \&numify,
172	'cmp' => \&vcmp,
173	'<=>' => \&vcmp,
174	'bool' => \&vbool,
175	'nomethod' => \&vnoop,
176	);
177
178	my $VERSION_MAX = 0x7FFFFFFF;
179
180	eval "use warnings";
181	if ($@) {
182	eval '
183	package warnings;
184	sub enabled {return $^W;}
185	1;
186	';
187	}
188
189	sub new
190	{
191	my ($class, $value) = @_;
192	my $self = bless ({}, ref ($class) \|\| $class);
193
194	if ( ref($value) && eval('$value->isa("version")') ) {
195	# Can copy the elements directly
196	$self->{version} = [ @{$value->{version} } ];
197	$self->{qv} = 1 if $value->{qv};
198	$self->{alpha} = 1 if $value->{alpha};
199	$self->{original} = ''.$value->{original};
200	return $self;
201	}
202
203	my $currlocale = setlocale(LC_ALL);
204
205	# if the current locale uses commas for decimal points, we
206	# just replace commas with decimal places, rather than changing
207	# locales
208	if ( localeconv()->{decimal_point} eq ',' ) {
209	$value =~ tr/,/./;
210	}
211
212	if ( not defined $value or $value =~ /^undef$/ ) {
213	# RT #19517 - special case for undef comparison
214	# or someone forgot to pass a value
215	push @{$self->{version}}, 0;
216	$self->{original} = "0";
217	return ($self);
218	}
219
220	if ( $#_ == 2 ) { # must be CVS-style
221	$value = 'v'.$_[2];
222	}
223
224	$value = _un_vstring($value);
225
226	# exponential notation
227	if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
228	$value = sprintf("%.9f",$value);
229	$value =~ s/(0+)$//; # trim trailing zeros
230	}
231
232	# This is not very efficient, but it is morally equivalent
233	# to the XS code (as that is the reference implementation).
234	# See vutil/vutil.c for details
235	my $qv = 0;
236	my $alpha = 0;
237	my $width = 3;
238	my $saw_period = 0;
239	my $vinf = 0;
240	my ($start, $last, $pos, $s);
241	$s = 0;
242
243	while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
244	$s++;
245	}
246
247	if (substr($value,$s,1) eq 'v') {
248	$s++; # get past 'v'
249	$qv = 1; # force quoted version processing
250	}
251
252	$start = $last = $pos = $s;
253
254	# pre-scan the input string to check for decimals/underbars
255	while ( substr($value,$pos,1) =~ /[._\d,]/ ) {
256	if ( substr($value,$pos,1) eq '.' ) {
257	if ($alpha) {
258	Carp::croak("Invalid version format ".
259	"(underscores before decimal)");
260	}
261	$saw_period++;
262	$last = $pos;
263	}
264	elsif ( substr($value,$pos,1) eq '_' ) {
265	if ($alpha) {
266	require Carp;
267	Carp::croak("Invalid version format ".
268	"(multiple underscores)");
269	}
270	$alpha = 1;
271	$width = $pos - $last - 1; # natural width of sub-version
272	}
273	elsif ( substr($value,$pos,1) eq ','
274	and substr($value,$pos+1,1) =~ /[0-9]/ ) {
275	# looks like an unhandled locale
276	$saw_period++;
277	$last = $pos;
278	}
279	$pos++;
280	}
281
282	if ( $alpha && !$saw_period ) {
283	require Carp;
284	Carp::croak("Invalid version format ".
285	"(alpha without decimal)");
286	}
287
288	if ( $alpha && $saw_period && $width == 0 ) {
289	require Carp;
290	Carp::croak("Invalid version format ".
291	"(misplaced _ in number)");
292	}
293
294	if ( $saw_period > 1 ) {
295	$qv = 1; # force quoted version processing
296	}
297
298	$last = $pos;
299	$pos = $s;
300
301	if ( $qv ) {
302	$self->{qv} = 1;
303	}
304
305	if ( $alpha ) {
306	$self->{alpha} = 1;
307	}
308
309	if ( !$qv && $width < 3 ) {
310	$self->{width} = $width;
311	}
312
313	while ( substr($value,$pos,1) =~ /\d/ ) {
314	$pos++;
315	}
316
317	if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
318	my $rev;
319
320	while (1) {
321	$rev = 0;
322	{
323
324	# this is atoi() that delimits on underscores
325	my $end = $pos;
326	my $mult = 1;
327	my $orev;
328
329	# the following if() will only be true after the decimal
330	# point of a version originally created with a bare
331	# floating point number, i.e. not quoted in any way
332	if ( !$qv && $s > $start && $saw_period == 1 ) {
333	$mult *= 100;
334	while ( $s < $end ) {
335	$orev = $rev;
336	$rev += substr($value,$s,1) * $mult;
337	$mult /= 10;
338	if ( abs($orev) > abs($rev)
339	\|\| abs($rev) > abs($VERSION_MAX) ) {
340	if ( warnings::enabled("overflow") ) {
341	require Carp;
342	Carp::carp("Integer overflow in version");
343	}
344	$s = $end - 1;
345	$rev = $VERSION_MAX;
346	}
347	$s++;
348	if ( substr($value,$s,1) eq '_' ) {
349	$s++;
350	}
351	}
352	}
353	else {
354	while (--$end >= $s) {
355	$orev = $rev;
356	$rev += substr($value,$end,1) * $mult;
357	$mult *= 10;
358	if ( abs($orev) > abs($rev)
359	\|\| abs($rev) > abs($VERSION_MAX) ) {
360	if ( warnings::enabled("overflow") ) {
361	require Carp;
362	Carp::carp("Integer overflow in version");
363	}
364	$end = $s - 1;
365	$rev = $VERSION_MAX;
366	}
367	}
368	}
369	}
370
371	# Append revision
372	push @{$self->{version}}, $rev;
373	if ( substr($value,$pos,1) eq '.'
374	&& substr($value,$pos+1,1) =~ /\d/ ) {
375	$s = ++$pos;
376	}
377	elsif ( substr($value,$pos,1) eq '_'
378	&& substr($value,$pos+1,1) =~ /\d/ ) {
379	$s = ++$pos;
380	}
381	elsif ( substr($value,$pos,1) eq ','
382	&& substr($value,$pos+1,1) =~ /\d/ ) {
383	$s = ++$pos;
384	}
385	elsif ( substr($value,$pos,1) =~ /\d/ ) {
386	$s = $pos;
387	}
388	else {
389	$s = $pos;
390	last;
391	}
392	if ( $qv ) {
393	while ( substr($value,$pos,1) =~ /\d/ ) {
394	$pos++;
395	}
396	}
397	else {
398	my $digits = 0;
399	while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
400	if ( substr($value,$pos,1) ne '_' ) {
401	$digits++;
402	}
403	$pos++;
404	}
405	}
406	}
407	}
408	if ( $qv ) { # quoted versions always get at least three terms
409	my $len = scalar @{$self->{version}};
410	$len = 3 - $len;
411	while ($len-- > 0) {
412	push @{$self->{version}}, 0;
413	}
414	}
415
416	if ( substr($value,$pos) ) { # any remaining text
417	if ( warnings::enabled("misc") ) {
418	require Carp;
419	Carp::carp("Version string '$value' contains invalid data; ".
420	"ignoring: '".substr($value,$pos)."'");
421	}
422	}
423
424	# cache the original value for use when stringification
425	if ( $vinf ) {
426	$self->{vinf} = 1;
427	$self->{original} = 'v.Inf';
428	}
429	else {
430	$self->{original} = substr($value,0,$pos);
431	}
432
433	return ($self);
434	}
435
436	*parse = \&new;
437
438	sub numify
439	{
440	my ($self) = @_;
441	unless (_verify($self)) {
442	require Carp;
443	Carp::croak("Invalid version object");
444	}
445	my $width = $self->{width} \|\| 3;
446	my $alpha = $self->{alpha} \|\| "";
447	my $len = $#{$self->{version}};
448	my $digit = $self->{version}[0];
449	my $string = sprintf("%d.", $digit );
450
451	for ( my $i = 1 ; $i < $len ; $i++ ) {
452	$digit = $self->{version}[$i];
453	if ( $width < 3 ) {
454	my $denom = 10**(3-$width);
455	my $quot = int($digit/$denom);
456	my $rem = $digit - ($quot * $denom);
457	$string .= sprintf("%0".$width."d_%d", $quot, $rem);
458	}
459	else {
460	$string .= sprintf("%03d", $digit);
461	}
462	}
463
464	if ( $len > 0 ) {
465	$digit = $self->{version}[$len];
466	if ( $alpha && $width == 3 ) {
467	$string .= "_";
468	}
469	$string .= sprintf("%0".$width."d", $digit);
470	}
471	else # $len = 0
472	{
473	$string .= sprintf("000");
474	}
475
476	return $string;
477	}
478
479	sub normal
480	{
481	my ($self) = @_;
482	unless (_verify($self)) {
483	require Carp;
484	Carp::croak("Invalid version object");
485	}
486	my $alpha = $self->{alpha} \|\| "";
487	my $len = $#{$self->{version}};
488	my $digit = $self->{version}[0];
489	my $string = sprintf("v%d", $digit );
490
491	for ( my $i = 1 ; $i < $len ; $i++ ) {
492	$digit = $self->{version}[$i];
493	$string .= sprintf(".%d", $digit);
494	}
495
496	if ( $len > 0 ) {
497	$digit = $self->{version}[$len];
498	if ( $alpha ) {
499	$string .= sprintf("_%0d", $digit);
500	}
501	else {
502	$string .= sprintf(".%0d", $digit);
503	}
504	}
505
506	if ( $len <= 2 ) {
507	for ( $len = 2 - $len; $len != 0; $len-- ) {
508	$string .= sprintf(".%0d", 0);
509	}
510	}
511
512	return $string;
513	}
514
515	sub stringify
516	{
517	my ($self) = @_;
518	unless (_verify($self)) {
519	require Carp;
520	Carp::croak("Invalid version object");
521	}
522	return exists $self->{original}
523	? $self->{original}
524	: exists $self->{qv}
525	? $self->normal
526	: $self->numify;
527	}
528
529	sub vcmp
530	{
531	require UNIVERSAL;
532	my ($left,$right,$swap) = @_;
533	my $class = ref($left);
534	unless ( UNIVERSAL::isa($right, $class) ) {
535	$right = $class->new($right);
536	}
537
538	if ( $swap ) {
539	($left, $right) = ($right, $left);
540	}
541	unless (_verify($left)) {
542	require Carp;
543	Carp::croak("Invalid version object");
544	}
545	unless (_verify($right)) {
546	require Carp;
547	Carp::croak("Invalid version object");
548	}
549	my $l = $#{$left->{version}};
550	my $r = $#{$right->{version}};
551	my $m = $l < $r ? $l : $r;
552	my $lalpha = $left->is_alpha;
553	my $ralpha = $right->is_alpha;
554	my $retval = 0;
555	my $i = 0;
556	while ( $i <= $m && $retval == 0 ) {
557	$retval = $left->{version}[$i] <=> $right->{version}[$i];
558	$i++;
559	}
560
561	# tiebreaker for alpha with identical terms
562	if ( $retval == 0
563	&& $l == $r
564	&& $left->{version}[$m] == $right->{version}[$m]
565	&& ( $lalpha \|\| $ralpha ) ) {
566
567	if ( $lalpha && !$ralpha ) {
568	$retval = -1;
569	}
570	elsif ( $ralpha && !$lalpha) {
571	$retval = +1;
572	}
573	}
574
575	# possible match except for trailing 0's
576	if ( $retval == 0 && $l != $r ) {
577	if ( $l < $r ) {
578	while ( $i <= $r && $retval == 0 ) {
579	if ( $right->{version}[$i] != 0 ) {
580	$retval = -1; # not a match after all
581	}
582	$i++;
583	}
584	}
585	else {
586	while ( $i <= $l && $retval == 0 ) {
587	if ( $left->{version}[$i] != 0 ) {
588	$retval = +1; # not a match after all
589	}
590	$i++;
591	}
592	}
593	}
594
595	return $retval;
596	}
597
598	sub vbool {
599	my ($self) = @_;
600	return vcmp($self,$self->new("0"),1);
601	}
602
603	sub vnoop {
604	require Carp;
605	Carp::croak("operation not supported with version object");
606	}
607
608	sub is_alpha {
609	my ($self) = @_;
610	return (exists $self->{alpha});
611	}
612
613	sub qv {
614	my $value = shift;
615	my $class = 'version';
616	if (@_) {
617	$class = ref($value) \|\| $value;
618	$value = shift;
619	}
620
621	$value = _un_vstring($value);
622	$value = 'v'.$value unless $value =~ /(^v\|\d+\.\d+\.\d)/;
623	my $version = $class->new($value);
624	return $version;
625	}
626
627	*declare = \&qv;
628
629	sub is_qv {
630	my ($self) = @_;
631	return (exists $self->{qv});
632	}
633
634
635	sub _verify {
636	my ($self) = @_;
637	if ( ref($self)
638	&& eval { exists $self->{version} }
639	&& ref($self->{version}) eq 'ARRAY'
640	) {
641	return 1;
642	}
643	else {
644	return 0;
645	}
646	}
647
648	sub _un_vstring {
649	my $value = shift;
650	# may be a v-string
651	if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) {
652	my $tvalue = sprintf("v%vd",$value);
653	if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) {
654	# must be a v-string
655	$value = $tvalue;
656	}
657	}
658	return $value;
659	}
660
661	sub _VERSION {
662	my ($obj, $req) = @_;
663	my $class = ref($obj) \|\| $obj;
664
665	no strict 'refs';
666	if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
667	# file but no package
668	require Carp;
669	Carp::croak( "$class defines neither package nor VERSION"
670	."--version check failed");
671	}
672
673	my $version = eval "\$$class\::VERSION";
674	if ( defined $version ) {
675	local $^W if $] <= 5.008;
676	$version = version::vpp->new($version);
677	}
678
679	if ( defined $req ) {
680	unless ( defined $version ) {
681	require Carp;
682	my $msg = $] < 5.006
683	? "$class version $req required--this is only version "
684	: "$class does not define \$$class\::VERSION"
685	."--version check failed";
686
687	if ( $ENV{VERSION_DEBUG} ) {
688	Carp::confess($msg);
689	}
690	else {
691	Carp::croak($msg);
692	}
693	}
694
695	$req = version::vpp->new($req);
696
697	if ( $req > $version ) {
698	require Carp;
699	if ( $req->is_qv ) {
700	Carp::croak(
701	sprintf ("%s version %s required--".
702	"this is only version %s", $class,
703	$req->normal, $version->normal)
704	);
705	}
706	else {
707	Carp::croak(
708	sprintf ("%s version %s required--".
709	"this is only version %s", $class,
710	$req->stringify, $version->stringify)
711	);
712	}
713	}
714	}
715
716	return defined $version ? $version->stringify : undef;
717	}
718
719	1; #this line is important and will help the module return a true value