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