1 package Module::Metadata::Version;
4 # stolen from Module::Build::Version - this is perl licensed code,
10 eval "use version $VERSION";
11 if ($@) { # can't locate version files, use our own
13 # Avoid redefined warnings if an old version.pm was available
14 delete $version::{$_} foreach keys %version::;
16 # first we get the stub version module
19 s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
24 # and now get the current version::vpp code
27 s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
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';
40 # now we can safely subclass version, installed or not
48 Module::Metadata::Version - inlined version.pm fallback for Module::Metadata
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.
56 This is a horrible hack. But so is version.pm.
60 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
62 Documented by Matt S Trout (mst) <mst@shadowcat.co.uk>
66 Copyright (c) 2001-2006 Ken Williams. All rights reserved.
68 This library is free software; you can redistribute it and/or
69 modify it under the same terms as Perl itself.
73 perl(1), L<Module::Build::ModuleInfo>(3)
78 # stub version module to make everything else happy
84 use vars qw(@ISA $VERSION $CLASS *declare *qv);
90 push @ISA, "version::vpp";
92 *version::qv = \&version::vpp::qv;
93 *version::declare = \&version::vpp::declare;
94 *version::_VERSION = \&version::vpp::_VERSION;
95 if ($] > 5.009001 && $] <= 5.010000) {
97 *{'version::stringify'} = \*version::vpp::stringify;
98 *{'version::(""'} = \*version::vpp::stringify;
99 *{'version::new'} = \*version::vpp::new;
102 # Preloaded methods go here.
107 # Set up any derived class
108 unless ($class eq 'version') {
110 *{$class.'::declare'} = \&version::declare;
111 *{$class.'::qv'} = \&version::qv;
115 if (@_) { # any remaining terms are arguments
116 map { $args{$_} = 1 } @_
118 else { # no parameters at all on use line
122 'UNIVERSAL::VERSION' => 1,
126 my $callpkg = caller();
128 if (exists($args{declare})) {
129 *{$callpkg."::declare"} =
130 sub {return $class->declare(shift) }
131 unless defined(&{$callpkg.'::declare'});
134 if (exists($args{qv})) {
136 sub {return $class->qv(shift) }
137 unless defined(&{"$callpkg\::qv"});
140 if (exists($args{'UNIVERSAL::VERSION'})) {
142 *UNIVERSAL::VERSION = \&version::_VERSION;
145 if (exists($args{'VERSION'})) {
146 *{$callpkg."::VERSION"} = \&version::_VERSION;
152 # replace everything from here to the end with the current version/vpp.pm
153 package version::vpp;
156 use POSIX qw/locale_h/;
158 use vars qw ($VERSION @ISA @REGEXS);
160 $VERSION = eval $VERSION;
163 ^v? # optional leading 'v'
164 (\d*) # major revision not required
165 \. # requires at least one decimal
175 'nomethod' => \&vnoop,
178 my $VERSION_MAX = 0x7FFFFFFF;
184 sub enabled {return $^W;}
191 my ($class, $value) = @_;
192 my $self = bless ({}, ref ($class) || $class);
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};
203 my $currlocale = setlocale(LC_ALL);
205 # if the current locale uses commas for decimal points, we
206 # just replace commas with decimal places, rather than changing
208 if ( localeconv()->{decimal_point} eq ',' ) {
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";
220 if ( $#_ == 2 ) { # must be CVS-style
224 $value = _un_vstring($value);
226 # exponential notation
227 if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
228 $value = sprintf("%.9f",$value);
229 $value =~ s/(0+)$//; # trim trailing zeros
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
240 my ($start, $last, $pos, $s);
243 while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
247 if (substr($value,$s,1) eq 'v') {
249 $qv = 1; # force quoted version processing
252 $start = $last = $pos = $s;
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 '.' ) {
258 Carp::croak("Invalid version format ".
259 "(underscores before decimal)");
264 elsif ( substr($value,$pos,1) eq '_' ) {
267 Carp::croak("Invalid version format ".
268 "(multiple underscores)");
271 $width = $pos - $last - 1; # natural width of sub-version
273 elsif ( substr($value,$pos,1) eq ','
274 and substr($value,$pos+1,1) =~ /[0-9]/ ) {
275 # looks like an unhandled locale
282 if ( $alpha && !$saw_period ) {
284 Carp::croak("Invalid version format ".
285 "(alpha without decimal)");
288 if ( $alpha && $saw_period && $width == 0 ) {
290 Carp::croak("Invalid version format ".
291 "(misplaced _ in number)");
294 if ( $saw_period > 1 ) {
295 $qv = 1; # force quoted version processing
309 if ( !$qv && $width < 3 ) {
310 $self->{width} = $width;
313 while ( substr($value,$pos,1) =~ /\d/ ) {
317 if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
324 # this is atoi() that delimits on underscores
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 ) {
334 while ( $s < $end ) {
336 $rev += substr($value,$s,1) * $mult;
338 if ( abs($orev) > abs($rev)
339 || abs($rev) > abs($VERSION_MAX) ) {
340 if ( warnings::enabled("overflow") ) {
342 Carp::carp("Integer overflow in version");
348 if ( substr($value,$s,1) eq '_' ) {
354 while (--$end >= $s) {
356 $rev += substr($value,$end,1) * $mult;
358 if ( abs($orev) > abs($rev)
359 || abs($rev) > abs($VERSION_MAX) ) {
360 if ( warnings::enabled("overflow") ) {
362 Carp::carp("Integer overflow in version");
372 push @{$self->{version}}, $rev;
373 if ( substr($value,$pos,1) eq '.'
374 && substr($value,$pos+1,1) =~ /\d/ ) {
377 elsif ( substr($value,$pos,1) eq '_'
378 && substr($value,$pos+1,1) =~ /\d/ ) {
381 elsif ( substr($value,$pos,1) eq ','
382 && substr($value,$pos+1,1) =~ /\d/ ) {
385 elsif ( substr($value,$pos,1) =~ /\d/ ) {
393 while ( substr($value,$pos,1) =~ /\d/ ) {
399 while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
400 if ( substr($value,$pos,1) ne '_' ) {
408 if ( $qv ) { # quoted versions always get at least three terms
409 my $len = scalar @{$self->{version}};
412 push @{$self->{version}}, 0;
416 if ( substr($value,$pos) ) { # any remaining text
417 if ( warnings::enabled("misc") ) {
419 Carp::carp("Version string '$value' contains invalid data; ".
420 "ignoring: '".substr($value,$pos)."'");
424 # cache the original value for use when stringification
427 $self->{original} = 'v.Inf';
430 $self->{original} = substr($value,0,$pos);
441 unless (_verify($self)) {
443 Carp::croak("Invalid version object");
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 );
451 for ( my $i = 1 ; $i < $len ; $i++ ) {
452 $digit = $self->{version}[$i];
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);
460 $string .= sprintf("%03d", $digit);
465 $digit = $self->{version}[$len];
466 if ( $alpha && $width == 3 ) {
469 $string .= sprintf("%0".$width."d", $digit);
473 $string .= sprintf("000");
482 unless (_verify($self)) {
484 Carp::croak("Invalid version object");
486 my $alpha = $self->{alpha} || "";
487 my $len = $#{$self->{version}};
488 my $digit = $self->{version}[0];
489 my $string = sprintf("v%d", $digit );
491 for ( my $i = 1 ; $i < $len ; $i++ ) {
492 $digit = $self->{version}[$i];
493 $string .= sprintf(".%d", $digit);
497 $digit = $self->{version}[$len];
499 $string .= sprintf("_%0d", $digit);
502 $string .= sprintf(".%0d", $digit);
507 for ( $len = 2 - $len; $len != 0; $len-- ) {
508 $string .= sprintf(".%0d", 0);
518 unless (_verify($self)) {
520 Carp::croak("Invalid version object");
522 return exists $self->{original}
532 my ($left,$right,$swap) = @_;
533 my $class = ref($left);
534 unless ( UNIVERSAL::isa($right, $class) ) {
535 $right = $class->new($right);
539 ($left, $right) = ($right, $left);
541 unless (_verify($left)) {
543 Carp::croak("Invalid version object");
545 unless (_verify($right)) {
547 Carp::croak("Invalid version object");
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;
556 while ( $i <= $m && $retval == 0 ) {
557 $retval = $left->{version}[$i] <=> $right->{version}[$i];
561 # tiebreaker for alpha with identical terms
564 && $left->{version}[$m] == $right->{version}[$m]
565 && ( $lalpha || $ralpha ) ) {
567 if ( $lalpha && !$ralpha ) {
570 elsif ( $ralpha && !$lalpha) {
575 # possible match except for trailing 0's
576 if ( $retval == 0 && $l != $r ) {
578 while ( $i <= $r && $retval == 0 ) {
579 if ( $right->{version}[$i] != 0 ) {
580 $retval = -1; # not a match after all
586 while ( $i <= $l && $retval == 0 ) {
587 if ( $left->{version}[$i] != 0 ) {
588 $retval = +1; # not a match after all
600 return vcmp($self,$self->new("0"),1);
605 Carp::croak("operation not supported with version object");
610 return (exists $self->{alpha});
615 my $class = 'version';
617 $class = ref($value) || $value;
621 $value = _un_vstring($value);
622 $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
623 my $version = $class->new($value);
631 return (exists $self->{qv});
638 && eval { exists $self->{version} }
639 && ref($self->{version}) eq 'ARRAY'
651 if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) {
652 my $tvalue = sprintf("v%vd",$value);
653 if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) {
662 my ($obj, $req) = @_;
663 my $class = ref($obj) || $obj;
666 if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
667 # file but no package
669 Carp::croak( "$class defines neither package nor VERSION"
670 ."--version check failed");
673 my $version = eval "\$$class\::VERSION";
674 if ( defined $version ) {
675 local $^W if $] <= 5.008;
676 $version = version::vpp->new($version);
679 if ( defined $req ) {
680 unless ( defined $version ) {
683 ? "$class version $req required--this is only version "
684 : "$class does not define \$$class\::VERSION"
685 ."--version check failed";
687 if ( $ENV{VERSION_DEBUG} ) {
695 $req = version::vpp->new($req);
697 if ( $req > $version ) {
701 sprintf ("%s version %s required--".
702 "this is only version %s", $class,
703 $req->normal, $version->normal)
708 sprintf ("%s version %s required--".
709 "this is only version %s", $class,
710 $req->stringify, $version->stringify)
716 return defined $version ? $version->stringify : undef;
719 1; #this line is important and will help the module return a true value