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