cpan/Module-Build/lib/Module/Build/Version.pm

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