lib/Module/Build/Version.pm

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