File Coverage

blib/lib/version/vpp.pm
Criterion Covered Total %
statement 465 532 87.4
branch 195 276 70.6
condition 109 158 68.9
subroutine 48 49 97.9
pod 0 16 0.0
total 817 1031 79.2


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