This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH [perl #121144]: \S, \W, etc fail for above ASCII
[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);
05402f6b 125$VERSION = 0.9907;
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
637sub new
638{
639 my ($class, $value) = @_;
640 unless (defined $class) {
641 require Carp;
642 Carp::croak('Usage: version::new(class, version)');
643 }
644 my $self = bless ({}, ref ($class) || $class);
645 my $qv = FALSE;
646
647 if ( ref($value) && eval('$value->isa("version")') ) {
648 # Can copy the elements directly
649 $self->{version} = [ @{$value->{version} } ];
650 $self->{qv} = 1 if $value->{qv};
651 $self->{alpha} = 1 if $value->{alpha};
652 $self->{original} = ''.$value->{original};
653 return $self;
654 }
655
4141ef59
JP
656 if ( not defined $value or $value =~ /^undef$/ ) {
657 # RT #19517 - special case for undef comparison
658 # or someone forgot to pass a value
659 push @{$self->{version}}, 0;
660 $self->{original} = "0";
661 return ($self);
662 }
663
664 if ( $#_ == 2 ) { # must be CVS-style
665 $value = $_[2];
666 $qv = TRUE;
667 }
668
ab4e0d4b
JP
669 if (ref($value) =~ m/ARRAY|HASH/) {
670 require Carp;
671 Carp::croak("Invalid version format (non-numeric data)");
672 }
673
4141ef59
JP
674 $value = _un_vstring($value);
675
858cc5e3
JP
676 if ($Config{d_setlocale}) {
677 use POSIX qw/locale_h/;
678 use if $Config{d_setlocale}, 'locale';
679 my $currlocale = setlocale(LC_ALL);
680
681 # if the current locale uses commas for decimal points, we
682 # just replace commas with decimal places, rather than changing
683 # locales
684 if ( localeconv()->{decimal_point} eq ',' ) {
685 $value =~ tr/,/./;
686 }
687 }
688
4141ef59
JP
689 # exponential notation
690 if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
691 $value = sprintf("%.9f",$value);
692 $value =~ s/(0+)$//; # trim trailing zeros
693 }
694
695 my $s = scan_version($value, \$self, $qv);
696
697 if ($s) { # must be something left over
698 warn("Version string '%s' contains invalid data; "
699 ."ignoring: '%s'", $value, $s);
700 }
701
702 return ($self);
703}
704
705*parse = \&new;
706
707sub numify
708{
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
748sub normal
749{
750 my ($self) = @_;
751 unless (_verify($self)) {
752 require Carp;
753 Carp::croak("Invalid version object");
754 }
755 my $alpha = $self->{alpha} || "";
756 my $len = $#{$self->{version}};
757 my $digit = $self->{version}[0];
758 my $string = sprintf("v%d", $digit );
759
760 for ( my $i = 1 ; $i < $len ; $i++ ) {
761 $digit = $self->{version}[$i];
762 $string .= sprintf(".%d", $digit);
763 }
764
765 if ( $len > 0 ) {
766 $digit = $self->{version}[$len];
767 if ( $alpha ) {
768 $string .= sprintf("_%0d", $digit);
769 }
770 else {
771 $string .= sprintf(".%0d", $digit);
772 }
773 }
774
775 if ( $len <= 2 ) {
776 for ( $len = 2 - $len; $len != 0; $len-- ) {
777 $string .= sprintf(".%0d", 0);
778 }
779 }
780
781 return $string;
782}
783
784sub stringify
785{
786 my ($self) = @_;
787 unless (_verify($self)) {
788 require Carp;
789 Carp::croak("Invalid version object");
790 }
791 return exists $self->{original}
792 ? $self->{original}
793 : exists $self->{qv}
794 ? $self->normal
795 : $self->numify;
796}
797
798sub vcmp
799{
800 require UNIVERSAL;
801 my ($left,$right,$swap) = @_;
802 my $class = ref($left);
803 unless ( UNIVERSAL::isa($right, $class) ) {
804 $right = $class->new($right);
805 }
806
807 if ( $swap ) {
808 ($left, $right) = ($right, $left);
809 }
810 unless (_verify($left)) {
811 require Carp;
812 Carp::croak("Invalid version object");
813 }
814 unless (_verify($right)) {
815 require Carp;
816 Carp::croak("Invalid version format");
817 }
818 my $l = $#{$left->{version}};
819 my $r = $#{$right->{version}};
820 my $m = $l < $r ? $l : $r;
821 my $lalpha = $left->is_alpha;
822 my $ralpha = $right->is_alpha;
823 my $retval = 0;
824 my $i = 0;
825 while ( $i <= $m && $retval == 0 ) {
826 $retval = $left->{version}[$i] <=> $right->{version}[$i];
827 $i++;
828 }
829
830 # tiebreaker for alpha with identical terms
831 if ( $retval == 0
832 && $l == $r
833 && $left->{version}[$m] == $right->{version}[$m]
834 && ( $lalpha || $ralpha ) ) {
835
836 if ( $lalpha && !$ralpha ) {
837 $retval = -1;
838 }
839 elsif ( $ralpha && !$lalpha) {
840 $retval = +1;
841 }
842 }
843
844 # possible match except for trailing 0's
845 if ( $retval == 0 && $l != $r ) {
846 if ( $l < $r ) {
847 while ( $i <= $r && $retval == 0 ) {
848 if ( $right->{version}[$i] != 0 ) {
849 $retval = -1; # not a match after all
850 }
851 $i++;
852 }
853 }
854 else {
855 while ( $i <= $l && $retval == 0 ) {
856 if ( $left->{version}[$i] != 0 ) {
857 $retval = +1; # not a match after all
858 }
859 $i++;
860 }
861 }
862 }
863
864 return $retval;
865}
866
867sub vbool {
868 my ($self) = @_;
869 return vcmp($self,$self->new("0"),1);
870}
871
872sub vnoop {
873 require Carp;
874 Carp::croak("operation not supported with version object");
875}
876
877sub is_alpha {
878 my ($self) = @_;
879 return (exists $self->{alpha});
880}
881
882sub qv {
883 my $value = shift;
884 my $class = $CLASS;
885 if (@_) {
886 $class = ref($value) || $value;
887 $value = shift;
888 }
889
890 $value = _un_vstring($value);
891 $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
892 my $obj = $CLASS->new($value);
893 return bless $obj, $class;
894}
895
896*declare = \&qv;
897
898sub is_qv {
899 my ($self) = @_;
900 return (exists $self->{qv});
901}
902
903
904sub _verify {
905 my ($self) = @_;
906 if ( ref($self)
907 && eval { exists $self->{version} }
908 && ref($self->{version}) eq 'ARRAY'
909 ) {
910 return 1;
911 }
912 else {
913 return 0;
914 }
915}
916
917sub _is_non_alphanumeric {
918 my $s = shift;
919 $s = new charstar $s;
920 while ($s) {
921 return 0 if isSPACE($s); # early out
922 return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
923 $s++;
924 }
925 return 0;
926}
927
928sub _un_vstring {
929 my $value = shift;
930 # may be a v-string
931 if ( length($value) >= 3 && $value !~ /[._]/
932 && _is_non_alphanumeric($value)) {
933 my $tvalue;
934 if ( $] ge 5.008_001 ) {
935 $tvalue = _find_magic_vstring($value);
936 $value = $tvalue if length $tvalue;
937 }
938 elsif ( $] ge 5.006_000 ) {
939 $tvalue = sprintf("v%vd",$value);
940 if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
941 # must be a v-string
942 $value = $tvalue;
943 }
944 }
945 }
946 return $value;
947}
948
949sub _find_magic_vstring {
950 my $value = shift;
951 my $tvalue = '';
952 require B;
953 my $sv = B::svref_2object(\$value);
954 my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
955 while ( $magic ) {
956 if ( $magic->TYPE eq 'V' ) {
957 $tvalue = $magic->PTR;
958 $tvalue =~ s/^v?(.+)$/v$1/;
959 last;
960 }
961 else {
962 $magic = $magic->MOREMAGIC;
963 }
964 }
965 return $tvalue;
966}
967
968sub _VERSION {
969 my ($obj, $req) = @_;
970 my $class = ref($obj) || $obj;
971
972 no strict 'refs';
973 if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
974 # file but no package
975 require Carp;
976 Carp::croak( "$class defines neither package nor VERSION"
977 ."--version check failed");
978 }
979
980 my $version = eval "\$$class\::VERSION";
981 if ( defined $version ) {
982 local $^W if $] <= 5.008;
983 $version = version::vpp->new($version);
984 }
985
986 if ( defined $req ) {
987 unless ( defined $version ) {
988 require Carp;
989 my $msg = $] < 5.006
990 ? "$class version $req required--this is only version "
991 : "$class does not define \$$class\::VERSION"
992 ."--version check failed";
993
994 if ( $ENV{VERSION_DEBUG} ) {
995 Carp::confess($msg);
996 }
997 else {
998 Carp::croak($msg);
999 }
1000 }
1001
1002 $req = version::vpp->new($req);
1003
1004 if ( $req > $version ) {
1005 require Carp;
1006 if ( $req->is_qv ) {
1007 Carp::croak(
1008 sprintf ("%s version %s required--".
1009 "this is only version %s", $class,
1010 $req->normal, $version->normal)
1011 );
1012 }
1013 else {
1014 Carp::croak(
1015 sprintf ("%s version %s required--".
1016 "this is only version %s", $class,
1017 $req->stringify, $version->stringify)
1018 );
1019 }
1020 }
1021 }
1022
1023 return defined $version ? $version->stringify : undef;
1024}
1025
10261; #this line is important and will help the module return a true value