This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3ac3f1361ff459038f1ce988b726bb64e5e880cf
[perl5.git] / cpan / version / lib / version / vpp.pm
1 package 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
5 use 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
19 sub 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
30 sub 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
42 sub increment {
43     my ($self) = @_;
44     $self->{current}++;
45 }
46
47 sub decrement {
48     my ($self) = @_;
49     $self->{current}--;
50 }
51
52 sub plus {
53     my ($self, $offset) = @_;
54     my $rself = $self->clone;
55     $rself->{current} += $offset;
56     return $rself;
57 }
58
59 sub minus {
60     my ($self, $offset) = @_;
61     my $rself = $self->clone;
62     $rself->{current} -= $offset;
63     return $rself;
64 }
65
66 sub multiply {
67     my ($left, $right, $swapped) = @_;
68     my $char = $left->thischar();
69     return $char * $right;
70 }
71
72 sub 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
80 sub 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
91 sub bool {
92     my ($self) = @_;
93     my $char = $self->thischar;
94     return ($char ne '');
95 }
96
97 sub 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
106 sub 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
118 package version::vpp;
119
120 use 5.006002;
121 use strict;
122
123 use Config;
124 use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
125 $VERSION = 0.9908;
126 $CLASS = 'version::vpp';
127
128 require version::regex;
129 *version::vpp::is_strict = \&version::regex::is_strict;
130 *version::vpp::is_lax = \&version::regex::is_lax;
131 *LAX = \$version::regex::LAX;
132 *STRICT = \$version::regex::STRICT;
133
134 use 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
151 eval "use warnings";
152 if ($@) {
153     eval '
154         package
155         warnings;
156         sub enabled {return $^W;}
157         1;
158     ';
159 }
160
161 sub 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
219 my $VERSION_MAX = 0x7FFFFFFF;
220
221 # implement prescan_version as closely to the C version as possible
222 use constant TRUE  => 1;
223 use constant FALSE => 0;
224
225 sub isDIGIT {
226     my ($char) = shift->thischar();
227     return ($char =~ /\d/);
228 }
229
230 sub isALPHA {
231     my ($char) = shift->thischar();
232     return ($char =~ /[a-zA-Z]/);
233 }
234
235 sub isSPACE {
236     my ($char) = shift->thischar();
237     return ($char =~ /\s/);
238 }
239
240 sub BADVERSION {
241     my ($s, $errstr, $error) = @_;
242     if ($errstr) {
243         $$errstr = $error;
244     }
245     return $s;
246 }
247
248 sub 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
271 dotted_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
432 version_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
457 sub 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') {
481             require Carp;
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
637 sub new {
638     my $class = shift;
639     unless (defined $class or $#_ > 1) {
640         require Carp;
641         Carp::croak('Usage: version::new(class, version)');
642     }
643
644     my $self = bless ({}, ref ($class) || $class);
645     my $qv = FALSE;
646
647     if ( $#_ == 1 ) { # must be CVS-style
648         $qv = TRUE;
649     }
650     my $value = pop; # always going to be the last element
651
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     }
660
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     }
668
669
670     if (ref($value) =~ m/ARRAY|HASH/) {
671         require Carp;
672         Carp::croak("Invalid version format (non-numeric data)");
673     }
674
675     $value = _un_vstring($value);
676
677     if ($Config{d_setlocale}) {
678         use POSIX qw/locale_h/;
679         use if $Config{d_setlocale}, 'locale';
680         my $currlocale = setlocale(LC_ALL);
681
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/,/./;
687         }
688     }
689
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);
704 }
705
706 *parse = \&new;
707
708 sub numify {
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
748 sub normal {
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
783 sub stringify {
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
796 sub vcmp {
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
864 sub vbool {
865     my ($self) = @_;
866     return vcmp($self,$self->new("0"),1);
867 }
868
869 sub vnoop {
870     require Carp;
871     Carp::croak("operation not supported with version object");
872 }
873
874 sub is_alpha {
875     my ($self) = @_;
876     return (exists $self->{alpha});
877 }
878
879 sub 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
895 sub is_qv {
896     my ($self) = @_;
897     return (exists $self->{qv});
898 }
899
900
901 sub _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
914 sub _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
925 sub _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
946 sub _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
965 sub _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
1023 1; #this line is important and will help the module return a true value