lib/Module/Build/Version.pm

   1 package Module::Build::Version;
   2 use strict;
   3
   4 eval "use version 0.661";
   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
  28     eval $vpp;
  29     $INC{'version/vpp.pm'} = 'inside Module::Build::Version';
  30     eval $version;
  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);
  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;
  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
  95 use Scalar::Util;
  96 use vars qw ($VERSION @ISA @REGEXS);
  97 $VERSION = 0.661;
  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 (
 107     '""'   => \&stringify,
 108     'cmp'  => \&vcmp,
 109     '<=>'  => \&vcmp,
 110 );
 111
 112 sub new
 113 {
 114         my ($class, $value) = @_;
 115         my $self = bless ({}, ref ($class) || $class);
 116
 117         if ( not defined $value or $value =~ /^undef$/ ) {
 118             # RT #19517 - special case for undef comparison
 119             # or someone forgot to pass a value
 120             push @{$self->{version}}, 0;
 121             return ($self);
 122         }
 123
 124         if ( $#_ == 2 ) { # must be CVS-style
 125             $value = 'v'.$_[2];
 126         }
 127
 128         # may be a v-string
 129         if ( $] >= 5.006_002 && length($value) >= 3 && $value !~ /[._]/ ) {
 130             my $tvalue = sprintf("%vd",$value);
 131             if ( $tvalue =~ /^\d+\.\d+\.\d+$/ ) {
 132                 # must be a v-string
 133                 $value = $tvalue;
 134             }
 135         }
 136
 137         # This is not very efficient, but it is morally equivalent
 138         # to the XS code (as that is the reference implementation).
 139         # See vutil/vutil.c for details
 140         my $qv = 0;
 141         my $alpha = 0;
 142         my $width = 3;
 143         my $saw_period = 0;
 144         my ($start, $last, $pos, $s);
 145         $s = 0;
 146
 147         while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
 148             $s++;
 149         }
 150
 151         if (substr($value,$s,1) eq 'v') {
 152             $s++;    # get past 'v'
 153             $qv = 1; # force quoted version processing
 154         }
 155
 156         $start = $last = $pos = $s;
 157
 158         # pre-scan the input string to check for decimals/underbars
 159         while ( substr($value,$pos,1) =~ /[._\d]/ ) {
 160             if ( substr($value,$pos,1) eq '.' ) {
 161                 die "Invalid version format (underscores before decimal)"
 162                   if $alpha;
 163                 $saw_period++;
 164                 $last = $pos;
 165             }
 166             elsif ( substr($value,$pos,1) eq '_' ) {
 167                 die "Invalid version format (multiple underscores)"
 168                   if $alpha;
 169                 $alpha = 1;
 170                 $width = $pos - $last - 1; # natural width of sub-version
 171             }
 172             $pos++;
 173         }
 174
 175         if ( $alpha && !$saw_period ) {
 176             die "Invalid version format (alpha without decimal)";
 177         }
 178
 179         if ( $saw_period > 1 ) {
 180             $qv = 1; # force quoted version processing
 181         }
 182
 183         $pos = $s;
 184
 185         if ( $qv ) {
 186             $self->{qv} = 1;
 187         }
 188
 189         if ( $alpha ) {
 190             $self->{alpha} = 1;
 191         }
 192
 193         if ( !$qv && $width < 3 ) {
 194             $self->{width} = $width;
 195         }
 196
 197         while ( substr($value,$pos,1) =~ /\d/ ) {
 198             $pos++;
 199         }
 200
 201         if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
 202             my $rev;
 203
 204             while (1) {
 205                 $rev = 0;
 206                 {
 207
 208                     # this is atoi() that delimits on underscores
 209                     my $end = $pos;
 210                     my $mult = 1;
 211                     my $orev;
 212
 213                     # the following if() will only be true after the decimal
 214                     # point of a version originally created with a bare
 215                     # floating point number, i.e. not quoted in any way
 216                     if ( !$qv && $s > $start && $saw_period == 1 ) {
 217                         $mult *= 100;
 218                         while ( $s < $end ) {
 219                             $orev = $rev;
 220                             $rev += substr($value,$s,1) * $mult;
 221                             $mult /= 10;
 222                             if ( abs($orev) > abs($rev) ) {
 223                                 die "Integer overflow in version";
 224                             }
 225                             $s++;
 226                             if ( substr($value,$s,1) eq '_' ) {
 227                                 $s++;
 228                             }
 229                         }
 230                     }
 231                     else {
 232                         while (--$end >= $s) {
 233                             $orev = $rev;
 234                             $rev += substr($value,$end,1) * $mult;
 235                             $mult *= 10;
 236                             if ( abs($orev) > abs($rev) ) {
 237                                 die "Integer overflow in version";
 238                             }
 239                         }
 240                     }
 241                 }
 242
 243                 # Append revision
 244                 push @{$self->{version}}, $rev;
 245                 if ( substr($value,$pos,1) eq '.'
 246                     && substr($value,$pos+1,1) =~ /\d/ ) {
 247                     $s = ++$pos;
 248                 }
 249                 elsif ( substr($value,$pos,1) eq '_'
 250                     && substr($value,$pos+1,1) =~ /\d/ ) {
 251                     $s = ++$pos;
 252                 }
 253                 elsif ( substr($value,$pos,1) =~ /\d/ ) {
 254                     $s = $pos;
 255                 }
 256                 else {
 257                     $s = $pos;
 258                     last;
 259                 }
 260                 if ( $qv ) {
 261                     while ( substr($value,$pos,1) =~ /\d/ ) {
 262                         $pos++;
 263                     }
 264                 }
 265                 else {
 266                     my $digits = 0;
 267                     while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
 268                         if ( substr($value,$pos,1) ne '_' ) {
 269                             $digits++;
 270                         }
 271                         $pos++;
 272                     }
 273                 }
 274             }
 275         }
 276         if ( $qv ) { # quoted versions always get at least three terms
 277             my $len = scalar @{$self->{version}};
 278             $len = 3 - $len;
 279             while ($len-- > 0) {
 280                 push @{$self->{version}}, 0;
 281             }
 282         }
 283
 284         if ( substr($value,$pos) ) { # any remaining text
 285             warn "Version string '$value' contains invalid data; ".
 286                  "ignoring: '".substr($value,$pos)."'";
 287         }
 288
 289         return ($self);
 290 }
 291
 292 sub numify
 293 {
 294     my ($self) = @_;
 295     unless (_verify($self)) {
 296         die "Invalid version object";
 297     }
 298     my $width = $self->{width} || 3;
 299     my $alpha = $self->{alpha} || "";
 300     my $len = $#{$self->{version}};
 301     my $digit = $self->{version}[0];
 302     my $string = sprintf("%d.", $digit );
 303
 304     for ( my $i = 1 ; $i < $len ; $i++ ) {
 305         $digit = $self->{version}[$i];
 306         if ( $width < 3 ) {
 307             my $denom = 10**(3-$width);
 308             my $quot = int($digit/$denom);
 309             my $rem = $digit - ($quot * $denom);
 310             $string .= sprintf("%0".$width."d_%d", $quot, $rem);
 311         }
 312         else {
 313             $string .= sprintf("%03d", $digit);
 314         }
 315     }
 316
 317     if ( $len > 0 ) {
 318         $digit = $self->{version}[$len];
 319         if ( $alpha && $width == 3 ) {
 320             $string .= "_";
 321         }
 322         $string .= sprintf("%0".$width."d", $digit);
 323     }
 324     else # $len = 0
 325     {
 326         $string .= sprintf("000");
 327     }
 328
 329     return $string;
 330 }
 331
 332 sub normal
 333 {
 334     my ($self) = @_;
 335     unless (_verify($self)) {
 336         die "Invalid version object";
 337     }
 338     my $alpha = $self->{alpha} || "";
 339     my $len = $#{$self->{version}};
 340     my $digit = $self->{version}[0];
 341     my $string = sprintf("v%d", $digit );
 342
 343     for ( my $i = 1 ; $i < $len ; $i++ ) {
 344         $digit = $self->{version}[$i];
 345         $string .= sprintf(".%d", $digit);
 346     }
 347
 348     if ( $len > 0 ) {
 349         $digit = $self->{version}[$len];
 350         if ( $alpha ) {
 351             $string .= sprintf("_%0d", $digit);
 352         }
 353         else {
 354             $string .= sprintf(".%0d", $digit);
 355         }
 356     }
 357
 358     if ( $len <= 2 ) {
 359         for ( $len = 2 - $len; $len != 0; $len-- ) {
 360             $string .= sprintf(".%0d", 0);
 361         }
 362     }
 363
 364     return $string;
 365 }
 366
 367 sub stringify
 368 {
 369     my ($self) = @_;
 370     unless (_verify($self)) {
 371         die "Invalid version object";
 372     }
 373     if ( exists $self->{qv} ) {
 374         return $self->normal;
 375     }
 376     else {
 377         return $self->numify;
 378     }
 379 }
 380
 381 sub vcmp
 382 {
 383     require UNIVERSAL;
 384     my ($left,$right,$swap) = @_;
 385     my $class = ref($left);
 386     unless ( UNIVERSAL::isa($right, $class) ) {
 387         $right = $class->new($right);
 388     }
 389
 390     if ( $swap ) {
 391         ($left, $right) = ($right, $left);
 392     }
 393     unless (_verify($left)) {
 394         die "Invalid version object";
 395     }
 396     unless (_verify($right)) {
 397         die "Invalid version object";
 398     }
 399     my $l = $#{$left->{version}};
 400     my $r = $#{$right->{version}};
 401     my $m = $l < $r ? $l : $r;
 402     my $lalpha = $left->is_alpha;
 403     my $ralpha = $right->is_alpha;
 404     my $retval = 0;
 405     my $i = 0;
 406     while ( $i <= $m && $retval == 0 ) {
 407         $retval = $left->{version}[$i] <=> $right->{version}[$i];
 408         $i++;
 409     }
 410
 411     # tiebreaker for alpha with identical terms
 412     if ( $retval == 0
 413         && $l == $r
 414         && $left->{version}[$m] == $right->{version}[$m]
 415         && ( $lalpha || $ralpha ) ) {
 416
 417         if ( $lalpha && !$ralpha ) {
 418             $retval = -1;
 419         }
 420         elsif ( $ralpha && !$lalpha) {
 421             $retval = +1;
 422         }
 423     }
 424
 425     # possible match except for trailing 0's
 426     if ( $retval == 0 && $l != $r ) {
 427         if ( $l < $r ) {
 428             while ( $i <= $r && $retval == 0 ) {
 429                 if ( $right->{version}[$i] != 0 ) {
 430                     $retval = -1; # not a match after all
 431                 }
 432                 $i++;
 433             }
 434         }
 435         else {
 436             while ( $i <= $l && $retval == 0 ) {
 437                 if ( $left->{version}[$i] != 0 ) {
 438                     $retval = +1; # not a match after all
 439                 }
 440                 $i++;
 441             }
 442         }
 443     }
 444
 445     return $retval;
 446 }
 447
 448 sub is_alpha {
 449     my ($self) = @_;
 450     return (exists $self->{alpha});
 451 }
 452
 453 sub qv {
 454     my ($value) = @_;
 455
 456     if ( $value =~ /\d+e-?\d+/ ) { # exponential notation
 457         $value = sprintf("%.9f",$value);
 458         $value =~ s/(0+)//;
 459     }
 460
 461     my $eval = eval 'Scalar::Util::isvstring($value)';
 462     if ( !$@ and $eval ) {
 463         $value = sprintf("v%vd",$value);
 464     }
 465     else {
 466         $value = 'v'.$value unless $value =~ /^v/;
 467     }
 468     return version->new($value); # always use base class
 469 }
 470
 471 sub _verify {
 472     my ($self) = @_;
 473     if (   Scalar::Util::reftype($self) eq 'HASH'
 474         && exists $self->{version}
 475         && ref($self->{version}) eq 'ARRAY'
 476         ) {
 477         return 1;
 478     }
 479     else {
 480         return 0;
 481     }
 482 }
 483
 484 # Thanks to Yitzchak Scott-Thoennes for this mode of operation
 485 {
 486     local $^W;
 487     *UNIVERSAL::VERSION = sub {
 488         my ($obj, $req) = @_;
 489         my $class = ref($obj) || $obj;
 490
 491         no strict 'refs';
 492         eval "require $class" unless %{"$class\::"}; # already existing
 493         die "$class defines neither package nor VERSION--version check failed"
 494             if $@ or not %{"$class\::"};
 495
 496         my $version = eval "\$$class\::VERSION";
 497         if ( defined $version ) {
 498             $version = version::vpp->new($version);
 499         }
 500
 501         if ( defined $req ) {
 502             if ( $req =~ /\d+e-?\d+/ ) { # exponential notation
 503                 $req = sprintf("%.9f",$req);
 504                 $req =~ s/(0+)$//;
 505             }
 506             unless ( defined $version ) {
 507                 my $msg =  "$class does not define ".
 508                            "\$$class\::VERSION--version check failed";
 509                 if ( $ENV{VERSION_DEBUG} ) {
 510                     require Carp;
 511                     Carp::confess($msg);
 512                 }
 513                 else {
 514                     die($msg);
 515                 }
 516             }
 517
 518             $req = version::vpp->new($req);
 519
 520             if ( $req > $version ) {
 521                 die sprintf ("%s version %s (%s) required--".
 522                      "this is only version %s (%s)", $class,
 523                      $req->numify, $req->normal,
 524                      $version->numify, $version->normal);
 525             }
 526         }
 527
 528         return defined $version ? $version->numify : undef;
 529     };
 530 }
 531
 532 1; #this line is important and will help the module return a true value