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