lib/Module/Build/Version.pm

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