File Coverage

lib/ExtUtils/MakeMaker/version/vpp.pm
Criterion Covered Total %
statement 41 549 7.4
branch 0 280 0.0
condition 0 174 0.0
subroutine 14 50 28.0
pod 0 16 0.0
total 55 1069 5.1


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