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