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
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.005_04;
121 use strict;
122
123 use POSIX qw/locale_h/;
124 use locale;
125 use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
126 $VERSION = 0.9906;
127 $CLASS = 'version::vpp';
128
129 require version::regex;
130 *version::vpp::is_strict = \&version::regex::is_strict;
131 *version::vpp::is_lax = \&version::regex::is_lax;
132 *LAX = \$version::regex::LAX;
133 *STRICT = \$version::regex::STRICT;
134
135 use 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
152 eval "use warnings";
153 if ($@) {
154     eval '
155         package
156         warnings;
157         sub enabled {return $^W;}
158         1;
159     ';
160 }
161
162 sub 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
220 my $VERSION_MAX = 0x7FFFFFFF;
221
222 # implement prescan_version as closely to the C version as possible
223 use constant TRUE  => 1;
224 use constant FALSE => 0;
225
226 sub isDIGIT {
227     my ($char) = shift->thischar();
228     return ($char =~ /\d/);
229 }
230
231 sub isALPHA {
232     my ($char) = shift->thischar();
233     return ($char =~ /[a-zA-Z]/);
234 }
235
236 sub isSPACE {
237     my ($char) = shift->thischar();
238     return ($char =~ /\s/);
239 }
240
241 sub BADVERSION {
242     my ($s, $errstr, $error) = @_;
243     if ($errstr) {
244         $$errstr = $error;
245     }
246     return $s;
247 }
248
249 sub 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
272 dotted_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
433 version_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
458 sub 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
638 sub 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
679         if (ref($value) =~ m/ARRAY|HASH/) {
680             require Carp;
681             Carp::croak("Invalid version format (non-numeric data)");
682         }
683
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
704 sub 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
745 sub 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
781 sub 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
795 sub 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
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