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