[Summary view] [Print] [Text view]

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