cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/vpp.pm

   1 #--------------------------------------------------------------------------#
   2 # This is a modified copy of version.pm 0.9909, bundled exclusively for
   3 # use by ExtUtils::Makemaker and its dependencies to bootstrap when
   4 # version.pm is not available.  It should not be used by ordinary modules.
   5 #--------------------------------------------------------------------------#
   6
   7 package ExtUtils::MakeMaker::charstar;
   8 # a little helper class to emulate C char* semantics in Perl
   9 # so that prescan_version can use the same code as in C
  10
  11 use overload (
  12     '""'        => \&thischar,
  13     '0+'        => \&thischar,
  14     '++'        => \&increment,
  15     '--'        => \&decrement,
  16     '+'         => \&plus,
  17     '-'         => \&minus,
  18     '*'         => \&multiply,
  19     'cmp'       => \&cmp,
  20     '<=>'       => \&spaceship,
  21     'bool'      => \&thischar,
  22     '='         => \&clone,
  23 );
  24
  25 sub new {
  26     my ($self, $string) = @_;
  27     my $class = ref($self) || $self;
  28
  29     my $obj = {
  30         string  => [split(//,$string)],
  31         current => 0,
  32     };
  33     return bless $obj, $class;
  34 }
  35
  36 sub thischar {
  37     my ($self) = @_;
  38     my $last = $#{$self->{string}};
  39     my $curr = $self->{current};
  40     if ($curr >= 0 && $curr <= $last) {
  41         return $self->{string}->[$curr];
  42     }
  43     else {
  44         return '';
  45     }
  46 }
  47
  48 sub increment {
  49     my ($self) = @_;
  50     $self->{current}++;
  51 }
  52
  53 sub decrement {
  54     my ($self) = @_;
  55     $self->{current}--;
  56 }
  57
  58 sub plus {
  59     my ($self, $offset) = @_;
  60     my $rself = $self->clone;
  61     $rself->{current} += $offset;
  62     return $rself;
  63 }
  64
  65 sub minus {
  66     my ($self, $offset) = @_;
  67     my $rself = $self->clone;
  68     $rself->{current} -= $offset;
  69     return $rself;
  70 }
  71
  72 sub multiply {
  73     my ($left, $right, $swapped) = @_;
  74     my $char = $left->thischar();
  75     return $char * $right;
  76 }
  77
  78 sub spaceship {
  79     my ($left, $right, $swapped) = @_;
  80     unless (ref($right)) { # not an object already
  81         $right = $left->new($right);
  82     }
  83     return $left->{current} <=> $right->{current};
  84 }
  85
  86 sub cmp {
  87     my ($left, $right, $swapped) = @_;
  88     unless (ref($right)) { # not an object already
  89         if (length($right) == 1) { # comparing single character only
  90             return $left->thischar cmp $right;
  91         }
  92         $right = $left->new($right);
  93     }
  94     return $left->currstr cmp $right->currstr;
  95 }
  96
  97 sub bool {
  98     my ($self) = @_;
  99     my $char = $self->thischar;
 100     return ($char ne '');
 101 }
 102
 103 sub clone {
 104     my ($left, $right, $swapped) = @_;
 105     $right = {
 106         string  => [@{$left->{string}}],
 107         current => $left->{current},
 108     };
 109     return bless $right, ref($left);
 110 }
 111
 112 sub currstr {
 113     my ($self, $s) = @_;
 114     my $curr = $self->{current};
 115     my $last = $#{$self->{string}};
 116     if (defined($s) && $s->{current} < $last) {
 117         $last = $s->{current};
 118     }
 119
 120     my $string = join('', @{$self->{string}}[$curr..$last]);
 121     return $string;
 122 }
 123
 124 package ExtUtils::MakeMaker::version::vpp;
 125
 126 use 5.006002;
 127 use strict;
 128
 129 use Config;
 130 use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
 131 $VERSION = '7.02';
 132 $CLASS = 'ExtUtils::MakeMaker::version::vpp';
 133
 134 require ExtUtils::MakeMaker::version::regex;
 135 *ExtUtils::MakeMaker::version::vpp::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict;
 136 *ExtUtils::MakeMaker::version::vpp::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax;
 137 *LAX = \$ExtUtils::MakeMaker::version::regex::LAX;
 138 *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT;
 139
 140 use overload (
 141     '""'       => \&stringify,
 142     '0+'       => \&numify,
 143     'cmp'      => \&vcmp,
 144     '<=>'      => \&vcmp,
 145     'bool'     => \&vbool,
 146     '+'        => \&vnoop,
 147     '-'        => \&vnoop,
 148     '*'        => \&vnoop,
 149     '/'        => \&vnoop,
 150     '+='        => \&vnoop,
 151     '-='        => \&vnoop,
 152     '*='        => \&vnoop,
 153     '/='        => \&vnoop,
 154     'abs'      => \&vnoop,
 155 );
 156
 157 eval "use warnings";
 158 if ($@) {
 159     eval '
 160         package
 161         warnings;
 162         sub enabled {return $^W;}
 163         1;
 164     ';
 165 }
 166
 167 sub import {
 168     no strict 'refs';
 169     my ($class) = shift;
 170
 171     # Set up any derived class
 172     unless ($class eq $CLASS) {
 173         local $^W;
 174         *{$class.'::declare'} =  \&{$CLASS.'::declare'};
 175         *{$class.'::qv'} = \&{$CLASS.'::qv'};
 176     }
 177
 178     my %args;
 179     if (@_) { # any remaining terms are arguments
 180         map { $args{$_} = 1 } @_
 181     }
 182     else { # no parameters at all on use line
 183         %args =
 184         (
 185             qv => 1,
 186             'UNIVERSAL::VERSION' => 1,
 187         );
 188     }
 189
 190     my $callpkg = caller();
 191
 192     if (exists($args{declare})) {
 193         *{$callpkg.'::declare'} =
 194             sub {return $class->declare(shift) }
 195           unless defined(&{$callpkg.'::declare'});
 196     }
 197
 198     if (exists($args{qv})) {
 199         *{$callpkg.'::qv'} =
 200             sub {return $class->qv(shift) }
 201           unless defined(&{$callpkg.'::qv'});
 202     }
 203
 204     if (exists($args{'UNIVERSAL::VERSION'})) {
 205         local $^W;
 206         *UNIVERSAL::VERSION
 207                 = \&{$CLASS.'::_VERSION'};
 208     }
 209
 210     if (exists($args{'VERSION'})) {
 211         *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
 212     }
 213
 214     if (exists($args{'is_strict'})) {
 215         *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
 216           unless defined(&{$callpkg.'::is_strict'});
 217     }
 218
 219     if (exists($args{'is_lax'})) {
 220         *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
 221           unless defined(&{$callpkg.'::is_lax'});
 222     }
 223 }
 224
 225 my $VERSION_MAX = 0x7FFFFFFF;
 226
 227 # implement prescan_version as closely to the C version as possible
 228 use constant TRUE  => 1;
 229 use constant FALSE => 0;
 230
 231 sub isDIGIT {
 232     my ($char) = shift->thischar();
 233     return ($char =~ /\d/);
 234 }
 235
 236 sub isALPHA {
 237     my ($char) = shift->thischar();
 238     return ($char =~ /[a-zA-Z]/);
 239 }
 240
 241 sub isSPACE {
 242     my ($char) = shift->thischar();
 243     return ($char =~ /\s/);
 244 }
 245
 246 sub BADVERSION {
 247     my ($s, $errstr, $error) = @_;
 248     if ($errstr) {
 249         $$errstr = $error;
 250     }
 251     return $s;
 252 }
 253
 254 sub prescan_version {
 255     my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
 256     my $qv          = defined $sqv          ? $$sqv          : FALSE;
 257     my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
 258     my $width       = defined $swidth       ? $$swidth       : 3;
 259     my $alpha       = defined $salpha       ? $$salpha       : FALSE;
 260
 261     my $d = $s;
 262
 263     if ($qv && isDIGIT($d)) {
 264         goto dotted_decimal_version;
 265     }
 266
 267     if ($d eq 'v') { # explicit v-string
 268         $d++;
 269         if (isDIGIT($d)) {
 270             $qv = TRUE;
 271         }
 272         else { # degenerate v-string
 273             # requires v1.2.3
 274             return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 275         }
 276
 277 dotted_decimal_version:
 278         if ($strict && $d eq '0' && isDIGIT($d+1)) {
 279             # no leading zeros allowed
 280             return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
 281         }
 282
 283         while (isDIGIT($d)) {   # integer part
 284             $d++;
 285         }
 286
 287         if ($d eq '.')
 288         {
 289             $saw_decimal++;
 290             $d++;               # decimal point
 291         }
 292         else
 293         {
 294             if ($strict) {
 295                 # require v1.2.3
 296                 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 297             }
 298             else {
 299                 goto version_prescan_finish;
 300             }
 301         }
 302
 303         {
 304             my $i = 0;
 305             my $j = 0;
 306             while (isDIGIT($d)) {       # just keep reading
 307                 $i++;
 308                 while (isDIGIT($d)) {
 309                     $d++; $j++;
 310                     # maximum 3 digits between decimal
 311                     if ($strict && $j > 3) {
 312                         return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
 313                     }
 314                 }
 315                 if ($d eq '_') {
 316                     if ($strict) {
 317                         return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
 318                     }
 319                     if ( $alpha ) {
 320                         return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
 321                     }
 322                     $d++;
 323                     $alpha = TRUE;
 324                 }
 325                 elsif ($d eq '.') {
 326                     if ($alpha) {
 327                         return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
 328                     }
 329                     $saw_decimal++;
 330                     $d++;
 331                 }
 332                 elsif (!isDIGIT($d)) {
 333                     last;
 334                 }
 335                 $j = 0;
 336             }
 337
 338             if ($strict && $i < 2) {
 339                 # requires v1.2.3
 340                 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 341             }
 342         }
 343     }                                   # end if dotted-decimal
 344     else
 345     {                                   # decimal versions
 346         my $j = 0;
 347         # special $strict case for leading '.' or '0'
 348         if ($strict) {
 349             if ($d eq '.') {
 350                 return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
 351             }
 352             if ($d eq '0' && isDIGIT($d+1)) {
 353                 return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
 354             }
 355         }
 356
 357         # and we never support negative version numbers
 358         if ($d eq '-') {
 359             return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
 360         }
 361
 362         # consume all of the integer part
 363         while (isDIGIT($d)) {
 364             $d++;
 365         }
 366
 367         # look for a fractional part
 368         if ($d eq '.') {
 369             # we found it, so consume it
 370             $saw_decimal++;
 371             $d++;
 372         }
 373         elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
 374             if ( $d == $s ) {
 375                 # found nothing
 376                 return BADVERSION($s,$errstr,"Invalid version format (version required)");
 377             }
 378             # found just an integer
 379             goto version_prescan_finish;
 380         }
 381         elsif ( $d == $s ) {
 382             # didn't find either integer or period
 383             return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
 384         }
 385         elsif ($d eq '_') {
 386             # underscore can't come after integer part
 387             if ($strict) {
 388                 return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
 389             }
 390             elsif (isDIGIT($d+1)) {
 391                 return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
 392             }
 393             else {
 394                 return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
 395             }
 396         }
 397         elsif ($d) {
 398             # anything else after integer part is just invalid data
 399             return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
 400         }
 401
 402         # scan the fractional part after the decimal point
 403         if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
 404                 # $strict or lax-but-not-the-end
 405                 return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
 406         }
 407
 408         while (isDIGIT($d)) {
 409             $d++; $j++;
 410             if ($d eq '.' && isDIGIT($d-1)) {
 411                 if ($alpha) {
 412                     return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
 413                 }
 414                 if ($strict) {
 415                     return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
 416                 }
 417                 $d = $s; # start all over again
 418                 $qv = TRUE;
 419                 goto dotted_decimal_version;
 420             }
 421             if ($d eq '_') {
 422                 if ($strict) {
 423                     return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
 424                 }
 425                 if ( $alpha ) {
 426                     return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
 427                 }
 428                 if ( ! isDIGIT($d+1) ) {
 429                     return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
 430                 }
 431                 $width = $j;
 432                 $d++;
 433                 $alpha = TRUE;
 434             }
 435         }
 436     }
 437
 438 version_prescan_finish:
 439     while (isSPACE($d)) {
 440         $d++;
 441     }
 442
 443     if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
 444         # trailing non-numeric data
 445         return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
 446     }
 447
 448     if (defined $sqv) {
 449         $$sqv = $qv;
 450     }
 451     if (defined $swidth) {
 452         $$swidth = $width;
 453     }
 454     if (defined $ssaw_decimal) {
 455         $$ssaw_decimal = $saw_decimal;
 456     }
 457     if (defined $salpha) {
 458         $$salpha = $alpha;
 459     }
 460     return $d;
 461 }
 462
 463 sub scan_version {
 464     my ($s, $rv, $qv) = @_;
 465     my $start;
 466     my $pos;
 467     my $last;
 468     my $errstr;
 469     my $saw_decimal = 0;
 470     my $width = 3;
 471     my $alpha = FALSE;
 472     my $vinf = FALSE;
 473     my @av;
 474
 475     $s = new ExtUtils::MakeMaker::charstar $s;
 476
 477     while (isSPACE($s)) { # leading whitespace is OK
 478         $s++;
 479     }
 480
 481     $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
 482         \$width, \$alpha);
 483
 484     if ($errstr) {
 485         # 'undef' is a special case and not an error
 486         if ( $s ne 'undef') {
 487             require Carp;
 488             Carp::croak($errstr);
 489         }
 490     }
 491
 492     $start = $s;
 493     if ($s eq 'v') {
 494         $s++;
 495     }
 496     $pos = $s;
 497
 498     if ( $qv ) {
 499         $$rv->{qv} = $qv;
 500     }
 501     if ( $alpha ) {
 502         $$rv->{alpha} = $alpha;
 503     }
 504     if ( !$qv && $width < 3 ) {
 505         $$rv->{width} = $width;
 506     }
 507
 508     while (isDIGIT($pos)) {
 509         $pos++;
 510     }
 511     if (!isALPHA($pos)) {
 512         my $rev;
 513
 514         for (;;) {
 515             $rev = 0;
 516             {
 517                 # this is atoi() that delimits on underscores
 518                 my $end = $pos;
 519                 my $mult = 1;
 520                 my $orev;
 521
 522                 #  the following if() will only be true after the decimal
 523                 #  point of a version originally created with a bare
 524                 #  floating point number, i.e. not quoted in any way
 525                 #
 526                 if ( !$qv && $s > $start && $saw_decimal == 1 ) {
 527                     $mult *= 100;
 528                     while ( $s < $end ) {
 529                         $orev = $rev;
 530                         $rev += $s * $mult;
 531                         $mult /= 10;
 532                         if (   (abs($orev) > abs($rev))
 533                             || (abs($rev) > $VERSION_MAX )) {
 534                             warn("Integer overflow in version %d",
 535                                            $VERSION_MAX);
 536                             $s = $end - 1;
 537                             $rev = $VERSION_MAX;
 538                             $vinf = 1;
 539                         }
 540                         $s++;
 541                         if ( $s eq '_' ) {
 542                             $s++;
 543                         }
 544                     }
 545                 }
 546                 else {
 547                     while (--$end >= $s) {
 548                         $orev = $rev;
 549                         $rev += $end * $mult;
 550                         $mult *= 10;
 551                         if (   (abs($orev) > abs($rev))
 552                             || (abs($rev) > $VERSION_MAX )) {
 553                             warn("Integer overflow in version");
 554                             $end = $s - 1;
 555                             $rev = $VERSION_MAX;
 556                             $vinf = 1;
 557                         }
 558                     }
 559                 }
 560             }
 561
 562             # Append revision
 563             push @av, $rev;
 564             if ( $vinf ) {
 565                 $s = $last;
 566                 last;
 567             }
 568             elsif ( $pos eq '.' ) {
 569                 $s = ++$pos;
 570             }
 571             elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
 572                 $s = ++$pos;
 573             }
 574             elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
 575                 $s = ++$pos;
 576             }
 577             elsif ( isDIGIT($pos) ) {
 578                 $s = $pos;
 579             }
 580             else {
 581                 $s = $pos;
 582                 last;
 583             }
 584             if ( $qv ) {
 585                 while ( isDIGIT($pos) ) {
 586                     $pos++;
 587                 }
 588             }
 589             else {
 590                 my $digits = 0;
 591                 while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
 592                     if ( $pos ne '_' ) {
 593                         $digits++;
 594                     }
 595                     $pos++;
 596                 }
 597             }
 598         }
 599     }
 600     if ( $qv ) { # quoted versions always get at least three terms
 601         my $len = $#av;
 602         #  This for loop appears to trigger a compiler bug on OS X, as it
 603         #  loops infinitely. Yes, len is negative. No, it makes no sense.
 604         #  Compiler in question is:
 605         #  gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
 606         #  for ( len = 2 - len; len > 0; len-- )
 607         #  av_push(MUTABLE_AV(sv), newSViv(0));
 608         #
 609         $len = 2 - $len;
 610         while ($len-- > 0) {
 611             push @av, 0;
 612         }
 613     }
 614
 615     # need to save off the current version string for later
 616     if ( $vinf ) {
 617         $$rv->{original} = "v.Inf";
 618         $$rv->{vinf} = 1;
 619     }
 620     elsif ( $s > $start ) {
 621         $$rv->{original} = $start->currstr($s);
 622         if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
 623             # need to insert a v to be consistent
 624             $$rv->{original} = 'v' . $$rv->{original};
 625         }
 626     }
 627     else {
 628         $$rv->{original} = '0';
 629         push(@av, 0);
 630     }
 631
 632     # And finally, store the AV in the hash
 633     $$rv->{version} = \@av;
 634
 635     # fix RT#19517 - special case 'undef' as string
 636     if ($s eq 'undef') {
 637         $s += 5;
 638     }
 639
 640     return $s;
 641 }
 642
 643 sub new {
 644     my $class = shift;
 645     unless (defined $class or $#_ > 1) {
 646         require Carp;
 647         Carp::croak('Usage: version::new(class, version)');
 648     }
 649
 650     my $self = bless ({}, ref ($class) || $class);
 651     my $qv = FALSE;
 652
 653     if ( $#_ == 1 ) { # must be CVS-style
 654         $qv = TRUE;
 655     }
 656     my $value = pop; # always going to be the last element
 657
 658     if ( ref($value) && eval('$value->isa("version")') ) {
 659         # Can copy the elements directly
 660         $self->{version} = [ @{$value->{version} } ];
 661         $self->{qv} = 1 if $value->{qv};
 662         $self->{alpha} = 1 if $value->{alpha};
 663         $self->{original} = ''.$value->{original};
 664         return $self;
 665     }
 666
 667     if ( not defined $value or $value =~ /^undef$/ ) {
 668         # RT #19517 - special case for undef comparison
 669         # or someone forgot to pass a value
 670         push @{$self->{version}}, 0;
 671         $self->{original} = "0";
 672         return ($self);
 673     }
 674
 675
 676     if (ref($value) =~ m/ARRAY|HASH/) {
 677         require Carp;
 678         Carp::croak("Invalid version format (non-numeric data)");
 679     }
 680
 681     $value = _un_vstring($value);
 682
 683     if ($Config{d_setlocale} && eval { require POSIX } ) {
 684       require locale;
 685         my $currlocale = POSIX::setlocale(&POSIX::LC_ALL);
 686
 687         # if the current locale uses commas for decimal points, we
 688         # just replace commas with decimal places, rather than changing
 689         # locales
 690         if ( POSIX::localeconv()->{decimal_point} eq ',' ) {
 691             $value =~ tr/,/./;
 692         }
 693     }
 694
 695     # exponential notation
 696     if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
 697         $value = sprintf("%.9f",$value);
 698         $value =~ s/(0+)$//; # trim trailing zeros
 699     }
 700
 701     my $s = scan_version($value, \$self, $qv);
 702
 703     if ($s) { # must be something left over
 704         warn("Version string '%s' contains invalid data; "
 705                    ."ignoring: '%s'", $value, $s);
 706     }
 707
 708     return ($self);
 709 }
 710
 711 *parse = \&new;
 712
 713 sub numify {
 714     my ($self) = @_;
 715     unless (_verify($self)) {
 716         require Carp;
 717         Carp::croak("Invalid version object");
 718     }
 719     my $width = $self->{width} || 3;
 720     my $alpha = $self->{alpha} || "";
 721     my $len = $#{$self->{version}};
 722     my $digit = $self->{version}[0];
 723     my $string = sprintf("%d.", $digit );
 724
 725     for ( my $i = 1 ; $i < $len ; $i++ ) {
 726         $digit = $self->{version}[$i];
 727         if ( $width < 3 ) {
 728             my $denom = 10**(3-$width);
 729             my $quot = int($digit/$denom);
 730             my $rem = $digit - ($quot * $denom);
 731             $string .= sprintf("%0".$width."d_%d", $quot, $rem);
 732         }
 733         else {
 734             $string .= sprintf("%03d", $digit);
 735         }
 736     }
 737
 738     if ( $len > 0 ) {
 739         $digit = $self->{version}[$len];
 740         if ( $alpha && $width == 3 ) {
 741             $string .= "_";
 742         }
 743         $string .= sprintf("%0".$width."d", $digit);
 744     }
 745     else # $len = 0
 746     {
 747         $string .= sprintf("000");
 748     }
 749
 750     return $string;
 751 }
 752
 753 sub normal {
 754     my ($self) = @_;
 755     unless (_verify($self)) {
 756         require Carp;
 757         Carp::croak("Invalid version object");
 758     }
 759     my $alpha = $self->{alpha} || "";
 760     my $len = $#{$self->{version}};
 761     my $digit = $self->{version}[0];
 762     my $string = sprintf("v%d", $digit );
 763
 764     for ( my $i = 1 ; $i < $len ; $i++ ) {
 765         $digit = $self->{version}[$i];
 766         $string .= sprintf(".%d", $digit);
 767     }
 768
 769     if ( $len > 0 ) {
 770         $digit = $self->{version}[$len];
 771         if ( $alpha ) {
 772             $string .= sprintf("_%0d", $digit);
 773         }
 774         else {
 775             $string .= sprintf(".%0d", $digit);
 776         }
 777     }
 778
 779     if ( $len <= 2 ) {
 780         for ( $len = 2 - $len; $len != 0; $len-- ) {
 781             $string .= sprintf(".%0d", 0);
 782         }
 783     }
 784
 785     return $string;
 786 }
 787
 788 sub stringify {
 789     my ($self) = @_;
 790     unless (_verify($self)) {
 791         require Carp;
 792         Carp::croak("Invalid version object");
 793     }
 794     return exists $self->{original}
 795         ? $self->{original}
 796         : exists $self->{qv}
 797             ? $self->normal
 798             : $self->numify;
 799 }
 800
 801 sub vcmp {
 802     require UNIVERSAL;
 803     my ($left,$right,$swap) = @_;
 804     my $class = ref($left);
 805     unless ( UNIVERSAL::isa($right, $class) ) {
 806         $right = $class->new($right);
 807     }
 808
 809     if ( $swap ) {
 810         ($left, $right) = ($right, $left);
 811     }
 812     unless (_verify($left)) {
 813         require Carp;
 814         Carp::croak("Invalid version object");
 815     }
 816     unless (_verify($right)) {
 817         require Carp;
 818         Carp::croak("Invalid version format");
 819     }
 820     my $l = $#{$left->{version}};
 821     my $r = $#{$right->{version}};
 822     my $m = $l < $r ? $l : $r;
 823     my $lalpha = $left->is_alpha;
 824     my $ralpha = $right->is_alpha;
 825     my $retval = 0;
 826     my $i = 0;
 827     while ( $i <= $m && $retval == 0 ) {
 828         $retval = $left->{version}[$i] <=> $right->{version}[$i];
 829         $i++;
 830     }
 831
 832     # tiebreaker for alpha with identical terms
 833     if ( $retval == 0
 834         && $l == $r
 835         && $left->{version}[$m] == $right->{version}[$m]
 836         && ( $lalpha || $ralpha ) ) {
 837
 838         if ( $lalpha && !$ralpha ) {
 839             $retval = -1;
 840         }
 841         elsif ( $ralpha && !$lalpha) {
 842             $retval = +1;
 843         }
 844     }
 845
 846     # possible match except for trailing 0's
 847     if ( $retval == 0 && $l != $r ) {
 848         if ( $l < $r ) {
 849             while ( $i <= $r && $retval == 0 ) {
 850                 if ( $right->{version}[$i] != 0 ) {
 851                     $retval = -1; # not a match after all
 852                 }
 853                 $i++;
 854             }
 855         }
 856         else {
 857             while ( $i <= $l && $retval == 0 ) {
 858                 if ( $left->{version}[$i] != 0 ) {
 859                     $retval = +1; # not a match after all
 860                 }
 861                 $i++;
 862             }
 863         }
 864     }
 865
 866     return $retval;
 867 }
 868
 869 sub vbool {
 870     my ($self) = @_;
 871     return vcmp($self,$self->new("0"),1);
 872 }
 873
 874 sub vnoop {
 875     require Carp;
 876     Carp::croak("operation not supported with version object");
 877 }
 878
 879 sub is_alpha {
 880     my ($self) = @_;
 881     return (exists $self->{alpha});
 882 }
 883
 884 sub qv {
 885     my $value = shift;
 886     my $class = $CLASS;
 887     if (@_) {
 888         $class = ref($value) || $value;
 889         $value = shift;
 890     }
 891
 892     $value = _un_vstring($value);
 893     $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
 894     my $obj = $CLASS->new($value);
 895     return bless $obj, $class;
 896 }
 897
 898 *declare = \&qv;
 899
 900 sub is_qv {
 901     my ($self) = @_;
 902     return (exists $self->{qv});
 903 }
 904
 905
 906 sub _verify {
 907     my ($self) = @_;
 908     if ( ref($self)
 909         && eval { exists $self->{version} }
 910         && ref($self->{version}) eq 'ARRAY'
 911         ) {
 912         return 1;
 913     }
 914     else {
 915         return 0;
 916     }
 917 }
 918
 919 sub _is_non_alphanumeric {
 920     my $s = shift;
 921     $s = new ExtUtils::MakeMaker::charstar $s;
 922     while ($s) {
 923         return 0 if isSPACE($s); # early out
 924         return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
 925         $s++;
 926     }
 927     return 0;
 928 }
 929
 930 sub _un_vstring {
 931     my $value = shift;
 932     # may be a v-string
 933     if ( length($value) >= 3 && $value !~ /[._]/
 934         && _is_non_alphanumeric($value)) {
 935         my $tvalue;
 936         if ( $] ge 5.008_001 ) {
 937             $tvalue = _find_magic_vstring($value);
 938             $value = $tvalue if length $tvalue;
 939         }
 940         elsif ( $] ge 5.006_000 ) {
 941             $tvalue = sprintf("v%vd",$value);
 942             if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
 943                 # must be a v-string
 944                 $value = $tvalue;
 945             }
 946         }
 947     }
 948     return $value;
 949 }
 950
 951 sub _find_magic_vstring {
 952     my $value = shift;
 953     my $tvalue = '';
 954     require B;
 955     my $sv = B::svref_2object(\$value);
 956     my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
 957     while ( $magic ) {
 958         if ( $magic->TYPE eq 'V' ) {
 959             $tvalue = $magic->PTR;
 960             $tvalue =~ s/^v?(.+)$/v$1/;
 961             last;
 962         }
 963         else {
 964             $magic = $magic->MOREMAGIC;
 965         }
 966     }
 967     return $tvalue;
 968 }
 969
 970 sub _VERSION {
 971     my ($obj, $req) = @_;
 972     my $class = ref($obj) || $obj;
 973
 974     no strict 'refs';
 975     if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
 976          # file but no package
 977         require Carp;
 978         Carp::croak( "$class defines neither package nor VERSION"
 979             ."--version check failed");
 980     }
 981
 982     my $version = eval "\$$class\::VERSION";
 983     if ( defined $version ) {
 984         local $^W if $] <= 5.008;
 985         $version = ExtUtils::MakeMaker::version::vpp->new($version);
 986     }
 987
 988     if ( defined $req ) {
 989         unless ( defined $version ) {
 990             require Carp;
 991             my $msg =  $] < 5.006
 992             ? "$class version $req required--this is only version "
 993             : "$class does not define \$$class\::VERSION"
 994               ."--version check failed";
 995
 996             if ( $ENV{VERSION_DEBUG} ) {
 997                 Carp::confess($msg);
 998             }
 999             else {
1000                 Carp::croak($msg);
1001             }
1002         }
1003
1004         $req = ExtUtils::MakeMaker::version::vpp->new($req);
1005
1006         if ( $req > $version ) {
1007             require Carp;
1008             if ( $req->is_qv ) {
1009                 Carp::croak(
1010                     sprintf ("%s version %s required--".
1011                         "this is only version %s", $class,
1012                         $req->normal, $version->normal)
1013                 );
1014             }
1015             else {
1016                 Carp::croak(
1017                     sprintf ("%s version %s required--".
1018                         "this is only version %s", $class,
1019                         $req->stringify, $version->stringify)
1020                 );
1021             }
1022         }
1023     }
1024
1025     return defined $version ? $version->stringify : undef;
1026 }
1027
1028 1; #this line is important and will help the module return a true value