lib/version/fallback/vpp.pm

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