This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix regression with $version::LAX and bump release
[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
effa684c 120use 5.005_04;
4141ef59
JP
121use strict;
122
123use POSIX qw/locale_h/;
124use locale;
db9cb848
JP
125use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
126$VERSION = 0.9906;
4141ef59
JP
127$CLASS = 'version::vpp';
128
129require version::regex;
130*version::vpp::is_strict = \&version::regex::is_strict;
131*version::vpp::is_lax = \&version::regex::is_lax;
db9cb848
JP
132*LAX = \$version::regex::LAX;
133*STRICT = \$version::regex::STRICT;
4141ef59
JP
134
135use overload (
136 '""' => \&stringify,
137 '0+' => \&numify,
138 'cmp' => \&vcmp,
139 '<=>' => \&vcmp,
140 'bool' => \&vbool,
141 '+' => \&vnoop,
142 '-' => \&vnoop,
143 '*' => \&vnoop,
144 '/' => \&vnoop,
145 '+=' => \&vnoop,
146 '-=' => \&vnoop,
147 '*=' => \&vnoop,
148 '/=' => \&vnoop,
149 'abs' => \&vnoop,
150);
151
152eval "use warnings";
153if ($@) {
154 eval '
155 package
156 warnings;
157 sub enabled {return $^W;}
158 1;
159 ';
160}
161
162sub import {
163 no strict 'refs';
164 my ($class) = shift;
165
166 # Set up any derived class
167 unless ($class eq $CLASS) {
168 local $^W;
169 *{$class.'::declare'} = \&{$CLASS.'::declare'};
170 *{$class.'::qv'} = \&{$CLASS.'::qv'};
171 }
172
173 my %args;
174 if (@_) { # any remaining terms are arguments
175 map { $args{$_} = 1 } @_
176 }
177 else { # no parameters at all on use line
178 %args =
179 (
180 qv => 1,
181 'UNIVERSAL::VERSION' => 1,
182 );
183 }
184
185 my $callpkg = caller();
186
187 if (exists($args{declare})) {
188 *{$callpkg.'::declare'} =
189 sub {return $class->declare(shift) }
190 unless defined(&{$callpkg.'::declare'});
191 }
192
193 if (exists($args{qv})) {
194 *{$callpkg.'::qv'} =
195 sub {return $class->qv(shift) }
196 unless defined(&{$callpkg.'::qv'});
197 }
198
199 if (exists($args{'UNIVERSAL::VERSION'})) {
200 local $^W;
201 *UNIVERSAL::VERSION
202 = \&{$CLASS.'::_VERSION'};
203 }
204
205 if (exists($args{'VERSION'})) {
206 *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
207 }
208
209 if (exists($args{'is_strict'})) {
210 *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
211 unless defined(&{$callpkg.'::is_strict'});
212 }
213
214 if (exists($args{'is_lax'})) {
215 *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
216 unless defined(&{$callpkg.'::is_lax'});
217 }
218}
219
220my $VERSION_MAX = 0x7FFFFFFF;
221
222# implement prescan_version as closely to the C version as possible
223use constant TRUE => 1;
224use constant FALSE => 0;
225
226sub isDIGIT {
227 my ($char) = shift->thischar();
228 return ($char =~ /\d/);
229}
230
231sub isALPHA {
232 my ($char) = shift->thischar();
233 return ($char =~ /[a-zA-Z]/);
234}
235
236sub isSPACE {
237 my ($char) = shift->thischar();
238 return ($char =~ /\s/);
239}
240
241sub BADVERSION {
242 my ($s, $errstr, $error) = @_;
243 if ($errstr) {
244 $$errstr = $error;
245 }
246 return $s;
247}
248
249sub prescan_version {
250 my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
251 my $qv = defined $sqv ? $$sqv : FALSE;
252 my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
253 my $width = defined $swidth ? $$swidth : 3;
254 my $alpha = defined $salpha ? $$salpha : FALSE;
255
256 my $d = $s;
257
258 if ($qv && isDIGIT($d)) {
259 goto dotted_decimal_version;
260 }
261
262 if ($d eq 'v') { # explicit v-string
263 $d++;
264 if (isDIGIT($d)) {
265 $qv = TRUE;
266 }
267 else { # degenerate v-string
268 # requires v1.2.3
269 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
270 }
271
272dotted_decimal_version:
273 if ($strict && $d eq '0' && isDIGIT($d+1)) {
274 # no leading zeros allowed
275 return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
276 }
277
278 while (isDIGIT($d)) { # integer part
279 $d++;
280 }
281
282 if ($d eq '.')
283 {
284 $saw_decimal++;
285 $d++; # decimal point
286 }
287 else
288 {
289 if ($strict) {
290 # require v1.2.3
291 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
292 }
293 else {
294 goto version_prescan_finish;
295 }
296 }
297
298 {
299 my $i = 0;
300 my $j = 0;
301 while (isDIGIT($d)) { # just keep reading
302 $i++;
303 while (isDIGIT($d)) {
304 $d++; $j++;
305 # maximum 3 digits between decimal
306 if ($strict && $j > 3) {
307 return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
308 }
309 }
310 if ($d eq '_') {
311 if ($strict) {
312 return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
313 }
314 if ( $alpha ) {
315 return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
316 }
317 $d++;
318 $alpha = TRUE;
319 }
320 elsif ($d eq '.') {
321 if ($alpha) {
322 return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
323 }
324 $saw_decimal++;
325 $d++;
326 }
327 elsif (!isDIGIT($d)) {
328 last;
329 }
330 $j = 0;
331 }
332
333 if ($strict && $i < 2) {
334 # requires v1.2.3
335 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
336 }
337 }
338 } # end if dotted-decimal
339 else
340 { # decimal versions
341 my $j = 0;
342 # special $strict case for leading '.' or '0'
343 if ($strict) {
344 if ($d eq '.') {
345 return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
346 }
347 if ($d eq '0' && isDIGIT($d+1)) {
348 return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
349 }
350 }
351
352 # and we never support negative version numbers
353 if ($d eq '-') {
354 return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
355 }
356
357 # consume all of the integer part
358 while (isDIGIT($d)) {
359 $d++;
360 }
361
362 # look for a fractional part
363 if ($d eq '.') {
364 # we found it, so consume it
365 $saw_decimal++;
366 $d++;
367 }
368 elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
369 if ( $d == $s ) {
370 # found nothing
371 return BADVERSION($s,$errstr,"Invalid version format (version required)");
372 }
373 # found just an integer
374 goto version_prescan_finish;
375 }
376 elsif ( $d == $s ) {
377 # didn't find either integer or period
378 return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
379 }
380 elsif ($d eq '_') {
381 # underscore can't come after integer part
382 if ($strict) {
383 return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
384 }
385 elsif (isDIGIT($d+1)) {
386 return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
387 }
388 else {
389 return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
390 }
391 }
392 elsif ($d) {
393 # anything else after integer part is just invalid data
394 return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
395 }
396
397 # scan the fractional part after the decimal point
398 if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
399 # $strict or lax-but-not-the-end
400 return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
401 }
402
403 while (isDIGIT($d)) {
404 $d++; $j++;
405 if ($d eq '.' && isDIGIT($d-1)) {
406 if ($alpha) {
407 return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
408 }
409 if ($strict) {
410 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
411 }
412 $d = $s; # start all over again
413 $qv = TRUE;
414 goto dotted_decimal_version;
415 }
416 if ($d eq '_') {
417 if ($strict) {
418 return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
419 }
420 if ( $alpha ) {
421 return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
422 }
423 if ( ! isDIGIT($d+1) ) {
424 return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
425 }
426 $width = $j;
427 $d++;
428 $alpha = TRUE;
429 }
430 }
431 }
432
433version_prescan_finish:
434 while (isSPACE($d)) {
435 $d++;
436 }
437
438 if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
439 # trailing non-numeric data
440 return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
441 }
442
443 if (defined $sqv) {
444 $$sqv = $qv;
445 }
446 if (defined $swidth) {
447 $$swidth = $width;
448 }
449 if (defined $ssaw_decimal) {
450 $$ssaw_decimal = $saw_decimal;
451 }
452 if (defined $salpha) {
453 $$salpha = $alpha;
454 }
455 return $d;
456}
457
458sub scan_version {
459 my ($s, $rv, $qv) = @_;
460 my $start;
461 my $pos;
462 my $last;
463 my $errstr;
464 my $saw_decimal = 0;
465 my $width = 3;
466 my $alpha = FALSE;
467 my $vinf = FALSE;
468 my @av;
469
470 $s = new charstar $s;
471
472 while (isSPACE($s)) { # leading whitespace is OK
473 $s++;
474 }
475
476 $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
477 \$width, \$alpha);
478
479 if ($errstr) {
480 # 'undef' is a special case and not an error
481 if ( $s ne 'undef') {
482 use Carp;
483 Carp::croak($errstr);
484 }
485 }
486
487 $start = $s;
488 if ($s eq 'v') {
489 $s++;
490 }
491 $pos = $s;
492
493 if ( $qv ) {
494 $$rv->{qv} = $qv;
495 }
496 if ( $alpha ) {
497 $$rv->{alpha} = $alpha;
498 }
499 if ( !$qv && $width < 3 ) {
500 $$rv->{width} = $width;
501 }
502
503 while (isDIGIT($pos)) {
504 $pos++;
505 }
506 if (!isALPHA($pos)) {
507 my $rev;
508
509 for (;;) {
510 $rev = 0;
511 {
512 # this is atoi() that delimits on underscores
513 my $end = $pos;
514 my $mult = 1;
515 my $orev;
516
517 # the following if() will only be true after the decimal
518 # point of a version originally created with a bare
519 # floating point number, i.e. not quoted in any way
520 #
521 if ( !$qv && $s > $start && $saw_decimal == 1 ) {
522 $mult *= 100;
523 while ( $s < $end ) {
524 $orev = $rev;
525 $rev += $s * $mult;
526 $mult /= 10;
527 if ( (abs($orev) > abs($rev))
528 || (abs($rev) > $VERSION_MAX )) {
529 warn("Integer overflow in version %d",
530 $VERSION_MAX);
531 $s = $end - 1;
532 $rev = $VERSION_MAX;
533 $vinf = 1;
534 }
535 $s++;
536 if ( $s eq '_' ) {
537 $s++;
538 }
539 }
540 }
541 else {
542 while (--$end >= $s) {
543 $orev = $rev;
544 $rev += $end * $mult;
545 $mult *= 10;
546 if ( (abs($orev) > abs($rev))
547 || (abs($rev) > $VERSION_MAX )) {
548 warn("Integer overflow in version");
549 $end = $s - 1;
550 $rev = $VERSION_MAX;
551 $vinf = 1;
552 }
553 }
554 }
555 }
556
557 # Append revision
558 push @av, $rev;
559 if ( $vinf ) {
560 $s = $last;
561 last;
562 }
563 elsif ( $pos eq '.' ) {
564 $s = ++$pos;
565 }
566 elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
567 $s = ++$pos;
568 }
569 elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
570 $s = ++$pos;
571 }
572 elsif ( isDIGIT($pos) ) {
573 $s = $pos;
574 }
575 else {
576 $s = $pos;
577 last;
578 }
579 if ( $qv ) {
580 while ( isDIGIT($pos) ) {
581 $pos++;
582 }
583 }
584 else {
585 my $digits = 0;
586 while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
587 if ( $pos ne '_' ) {
588 $digits++;
589 }
590 $pos++;
591 }
592 }
593 }
594 }
595 if ( $qv ) { # quoted versions always get at least three terms
596 my $len = $#av;
597 # This for loop appears to trigger a compiler bug on OS X, as it
598 # loops infinitely. Yes, len is negative. No, it makes no sense.
599 # Compiler in question is:
600 # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
601 # for ( len = 2 - len; len > 0; len-- )
602 # av_push(MUTABLE_AV(sv), newSViv(0));
603 #
604 $len = 2 - $len;
605 while ($len-- > 0) {
606 push @av, 0;
607 }
608 }
609
610 # need to save off the current version string for later
611 if ( $vinf ) {
612 $$rv->{original} = "v.Inf";
613 $$rv->{vinf} = 1;
614 }
615 elsif ( $s > $start ) {
616 $$rv->{original} = $start->currstr($s);
617 if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
618 # need to insert a v to be consistent
619 $$rv->{original} = 'v' . $$rv->{original};
620 }
621 }
622 else {
623 $$rv->{original} = '0';
624 push(@av, 0);
625 }
626
627 # And finally, store the AV in the hash
628 $$rv->{version} = \@av;
629
630 # fix RT#19517 - special case 'undef' as string
631 if ($s eq 'undef') {
632 $s += 5;
633 }
634
635 return $s;
636}
637
638sub new
639{
640 my ($class, $value) = @_;
641 unless (defined $class) {
642 require Carp;
643 Carp::croak('Usage: version::new(class, version)');
644 }
645 my $self = bless ({}, ref ($class) || $class);
646 my $qv = FALSE;
647
648 if ( ref($value) && eval('$value->isa("version")') ) {
649 # Can copy the elements directly
650 $self->{version} = [ @{$value->{version} } ];
651 $self->{qv} = 1 if $value->{qv};
652 $self->{alpha} = 1 if $value->{alpha};
653 $self->{original} = ''.$value->{original};
654 return $self;
655 }
656
657 my $currlocale = setlocale(LC_ALL);
658
659 # if the current locale uses commas for decimal points, we
660 # just replace commas with decimal places, rather than changing
661 # locales
662 if ( localeconv()->{decimal_point} eq ',' ) {
663 $value =~ tr/,/./;
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 if ( $#_ == 2 ) { # must be CVS-style
675 $value = $_[2];
676 $qv = TRUE;
677 }
678
ab4e0d4b
JP
679 if (ref($value) =~ m/ARRAY|HASH/) {
680 require Carp;
681 Carp::croak("Invalid version format (non-numeric data)");
682 }
683
4141ef59
JP
684 $value = _un_vstring($value);
685
686 # exponential notation
687 if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
688 $value = sprintf("%.9f",$value);
689 $value =~ s/(0+)$//; # trim trailing zeros
690 }
691
692 my $s = scan_version($value, \$self, $qv);
693
694 if ($s) { # must be something left over
695 warn("Version string '%s' contains invalid data; "
696 ."ignoring: '%s'", $value, $s);
697 }
698
699 return ($self);
700}
701
702*parse = \&new;
703
704sub numify
705{
706 my ($self) = @_;
707 unless (_verify($self)) {
708 require Carp;
709 Carp::croak("Invalid version object");
710 }
711 my $width = $self->{width} || 3;
712 my $alpha = $self->{alpha} || "";
713 my $len = $#{$self->{version}};
714 my $digit = $self->{version}[0];
715 my $string = sprintf("%d.", $digit );
716
717 for ( my $i = 1 ; $i < $len ; $i++ ) {
718 $digit = $self->{version}[$i];
719 if ( $width < 3 ) {
720 my $denom = 10**(3-$width);
721 my $quot = int($digit/$denom);
722 my $rem = $digit - ($quot * $denom);
723 $string .= sprintf("%0".$width."d_%d", $quot, $rem);
724 }
725 else {
726 $string .= sprintf("%03d", $digit);
727 }
728 }
729
730 if ( $len > 0 ) {
731 $digit = $self->{version}[$len];
732 if ( $alpha && $width == 3 ) {
733 $string .= "_";
734 }
735 $string .= sprintf("%0".$width."d", $digit);
736 }
737 else # $len = 0
738 {
739 $string .= sprintf("000");
740 }
741
742 return $string;
743}
744
745sub normal
746{
747 my ($self) = @_;
748 unless (_verify($self)) {
749 require Carp;
750 Carp::croak("Invalid version object");
751 }
752 my $alpha = $self->{alpha} || "";
753 my $len = $#{$self->{version}};
754 my $digit = $self->{version}[0];
755 my $string = sprintf("v%d", $digit );
756
757 for ( my $i = 1 ; $i < $len ; $i++ ) {
758 $digit = $self->{version}[$i];
759 $string .= sprintf(".%d", $digit);
760 }
761
762 if ( $len > 0 ) {
763 $digit = $self->{version}[$len];
764 if ( $alpha ) {
765 $string .= sprintf("_%0d", $digit);
766 }
767 else {
768 $string .= sprintf(".%0d", $digit);
769 }
770 }
771
772 if ( $len <= 2 ) {
773 for ( $len = 2 - $len; $len != 0; $len-- ) {
774 $string .= sprintf(".%0d", 0);
775 }
776 }
777
778 return $string;
779}
780
781sub stringify
782{
783 my ($self) = @_;
784 unless (_verify($self)) {
785 require Carp;
786 Carp::croak("Invalid version object");
787 }
788 return exists $self->{original}
789 ? $self->{original}
790 : exists $self->{qv}
791 ? $self->normal
792 : $self->numify;
793}
794
795sub vcmp
796{
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