[p5sagit/p5-mst-13.2.git] / lib / Module / Build / Version.pm

package Module::Build::Version;
use strict;

eval "use version 0.70";
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::Build::Version';
    eval $version; die $@ if $@;
    $INC{'version.pm'} = 'inside Module::Build::Version';
}

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

use overload (
    '""' => \&stringify,
);

sub new {
    my ($class, $value) = @_;
    my $self = $class->SUPER::new($value);
    $self->original($value);
    return $self;
}

sub original {
    my $self = shift;
    $self->{original} = shift if @_;
    return $self->{original};
}

sub stringify {
    my $self = shift;
    return $self->original;
}

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

use 5.005_04;
use strict;

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

$VERSION = 0.000;

$CLASS = 'version';

push @ISA, "version::vpp";
*version::qv = \&version::vpp::qv;

# Preloaded methods go here.
sub import {
    my ($class) = @_;
    my $callpkg = caller();
    no strict 'refs';
    
    *{$callpkg."::qv"} = 
	    sub {return bless version::qv(shift), $class }
	unless defined(&{"$callpkg\::qv"});

}

1;
# replace everything from here to the end with the current version/vpp.pm

package version::vpp;
use strict;

use locale;
use vars qw ($VERSION @ISA @REGEXS);
$VERSION = 0.71;

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,
);

sub new
{
	my ($class, $value) = @_;
	my $self = bless ({}, ref ($class) || $class);
	require POSIX;
	my $currlocale = POSIX::setlocale(&POSIX::LC_ALL);
	my $radix_comma = ( POSIX::localeconv()->{decimal_point} eq ',' );

	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;
	    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+)$//;
	}
	
	# if the original locale used commas for decimal points, we
	# just replace commas with decimal places, rather than changing
	# locales
	if ( $radix_comma ) {
	    $value =~ tr/,/./;
	}

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

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

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

	$start = $last = $pos = $s;
		
	# pre-scan the input string to check for decimals/underbars
	while ( substr($value,$pos,1) =~ /[._\d]/ ) {
	    if ( substr($value,$pos,1) eq '.' ) {
		if ($alpha) {
		    require Carp;
		    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
	    }
	    $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
	}

	$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) ) {
				require Carp;
				Carp::croak("Integer overflow in version");
			    }
			    $s++;
			    if ( substr($value,$s,1) eq '_' ) {
				$s++;
			    }
			}
		    }
		    else {
			while (--$end >= $s) {
			    $orev = $rev;
			    $rev += substr($value,$end,1) * $mult;
			    $mult *= 10;
			    if ( abs($orev) > abs($rev) ) {
				require Carp;
				Carp::croak("Integer overflow in version");
			    }
			}
		    }
		}

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

	if ( substr($value,$pos) ) { # any remaining text
	    warn "Version string '$value' contains invalid data; ".
	         "ignoring: '".substr($value,$pos)."'";
	}

	return ($self);
}

sub numify 
{
    my ($self) = @_;
    unless (_verify($self)) {
	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");
    }
    if ( exists $self->{qv} ) {
	return $self->normal;
    }
    else {
	return $self->numify;
    }
}

sub vcmp
{
    require UNIVERSAL;
    my ($left,$right,$swap) = @_;
    my $class = ref($left);
    unless ( UNIVERSAL::isa($right, $class) ) {
	$right = $class->new($right);
    }

    if ( $swap ) {
	($left, $right) = ($right, $left);
    }
    unless (_verify($left)) {
	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) = @_;

    $value = _un_vstring($value);
    $value = 'v'.$value unless $value =~ /^v/;
    return version->new($value); # always use base class
}

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("%vd",$value);
	if ( $tvalue =~ /^\d+\.\d+\.\d+$/ ) {
	    # must be a v-string
	    $value = $tvalue;
	}
    }
    return $value;
}

# Thanks to Yitzchak Scott-Thoennes for this mode of operation
{
    local $^W;
    *UNIVERSAL::VERSION = sub {
	my ($obj, $req) = @_;
	my $class = ref($obj) || $obj;

	no strict 'refs';
	eval "require $class" unless %{"$class\::"}; # already existing
	return undef if $@ =~ /Can't locate/ and not defined $req;
	
	if ( 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->numify, $version->numify)
		    );
		}
	    }
	}

	return defined $version ? $version->numify : undef;
    };
}

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