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