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