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