lib/Module/Metadata/Version.pm

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