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.006002;
121use strict;
122use warnings::register;
123
124use Config;
125
126our $VERSION = 0.9929;
127our $CLASS = 'version::vpp';
128our ($LAX, $STRICT, $WARN_CATEGORY);
129
130if ($] > 5.015) {
131    warnings::register_categories(qw/version/);
132    $WARN_CATEGORY = 'version';
133} else {
134    $WARN_CATEGORY = 'numeric';
135}
136
137require 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
143use overload (
144    '""'       => \&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);
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	no warnings qw/redefine/;
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    if ($saw_decimal > 1 && ($d-1) eq '.') {
441	# no trailing period allowed
442	return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)");
443    }
444
445    if (defined $sqv) {
446	$$sqv = $qv;
447    }
448    if (defined $swidth) {
449	$$swidth = $width;
450    }
451    if (defined $ssaw_decimal) {
452	$$ssaw_decimal = $saw_decimal;
453    }
454    if (defined $salpha) {
455	$$salpha = $alpha;
456    }
457    return $d;
458}
459
460sub scan_version {
461    my ($s, $rv, $qv) = @_;
462    my $start;
463    my $pos;
464    my $last;
465    my $errstr;
466    my $saw_decimal = 0;
467    my $width = 3;
468    my $alpha = FALSE;
469    my $vinf = FALSE;
470    my @av;
471
472    $s = new charstar $s;
473
474    while (isSPACE($s)) { # leading whitespace is OK
475	$s++;
476    }
477
478    $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
479	\$width, \$alpha);
480
481    if ($errstr) {
482	# 'undef' is a special case and not an error
483	if ( $s ne 'undef') {
484	    require Carp;
485	    Carp::croak($errstr);
486	}
487    }
488
489    $start = $s;
490    if ($s eq 'v') {
491	$s++;
492    }
493    $pos = $s;
494
495    if ( $qv ) {
496	$$rv->{qv} = $qv;
497    }
498    if ( $alpha ) {
499	$$rv->{alpha} = $alpha;
500    }
501    if ( !$qv && $width < 3 ) {
502	$$rv->{width} = $width;
503    }
504
505    while (isDIGIT($pos) || $pos eq '_') {
506	$pos++;
507    }
508    if (!isALPHA($pos)) {
509	my $rev;
510
511	for (;;) {
512	    $rev = 0;
513	    {
514  		# this is atoi() that delimits on underscores
515  		my $end = $pos;
516  		my $mult = 1;
517		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 		if ( !$qv && $s > $start && $saw_decimal == 1 ) {
524		    $mult *= 100;
525 		    while ( $s < $end ) {
526			next if $s eq '_';
527			$orev = $rev;
528 			$rev += $s * $mult;
529 			$mult /= 10;
530			if (   (abs($orev) > abs($rev))
531			    || (abs($rev) > $VERSION_MAX )) {
532			    warn("Integer overflow in version %d",
533					   $VERSION_MAX);
534			    $s = $end - 1;
535			    $rev = $VERSION_MAX;
536			    $vinf = 1;
537			}
538 			$s++;
539			if ( $s eq '_' ) {
540			    $s++;
541			}
542 		    }
543  		}
544 		else {
545 		    while (--$end >= $s) {
546			next if $end eq '_';
547			$orev = $rev;
548 			$rev += $end * $mult;
549 			$mult *= 10;
550			if (   (abs($orev) > abs($rev))
551			    || (abs($rev) > $VERSION_MAX )) {
552			    warn("Integer overflow in version");
553			    $end = $s - 1;
554			    $rev = $VERSION_MAX;
555			    $vinf = 1;
556			}
557 		    }
558 		}
559  	    }
560
561  	    # Append revision
562	    push @av, $rev;
563	    if ( $vinf ) {
564		$s = $last;
565		last;
566	    }
567	    elsif ( $pos eq '.' ) {
568		$s = ++$pos;
569	    }
570	    elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
571		$s = ++$pos;
572	    }
573	    elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
574		$s = ++$pos;
575	    }
576	    elsif ( isDIGIT($pos) ) {
577		$s = $pos;
578	    }
579	    else {
580		$s = $pos;
581		last;
582	    }
583	    if ( $qv ) {
584		while ( isDIGIT($pos) || $pos eq '_') {
585		    $pos++;
586		}
587	    }
588	    else {
589		my $digits = 0;
590		while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
591		    if ( $pos ne '_' ) {
592			$digits++;
593		    }
594		    $pos++;
595		}
596	    }
597	}
598    }
599    if ( $qv ) { # quoted versions always get at least three terms
600	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	$len = 2 - $len;
609	while ($len-- > 0) {
610	    push @av, 0;
611	}
612    }
613
614    # need to save off the current version string for later
615    if ( $vinf ) {
616	$$rv->{original} = "v.Inf";
617	$$rv->{vinf} = 1;
618    }
619    elsif ( $s > $start ) {
620	$$rv->{original} = $start->currstr($s);
621	if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
622	    # need to insert a v to be consistent
623	    $$rv->{original} = 'v' . $$rv->{original};
624	}
625    }
626    else {
627	$$rv->{original} = '0';
628	push(@av, 0);
629    }
630
631    # And finally, store the AV in the hash
632    $$rv->{version} = \@av;
633
634    # fix RT#19517 - special case 'undef' as string
635    if ($s eq 'undef') {
636	$s += 5;
637    }
638
639    return $s;
640}
641
642sub new {
643    my $class = shift;
644    unless (defined $class or $#_ > 1) {
645	require Carp;
646	Carp::croak('Usage: version::new(class, version)');
647    }
648
649    my $self = bless ({}, ref ($class) || $class);
650    my $qv = FALSE;
651
652    if ( $#_ == 1 ) { # must be CVS-style
653	$qv = TRUE;
654    }
655    my $value = pop; # always going to be the last element
656
657    if ( ref($value) && eval('$value->isa("version")') ) {
658	# Can copy the elements directly
659	$self->{version} = [ @{$value->{version} } ];
660	$self->{qv} = 1 if $value->{qv};
661	$self->{alpha} = 1 if $value->{alpha};
662	$self->{original} = ''.$value->{original};
663	return $self;
664    }
665
666    if ( not defined $value or $value =~ /^undef$/ ) {
667	# RT #19517 - special case for undef comparison
668	# or someone forgot to pass a value
669	push @{$self->{version}}, 0;
670	$self->{original} = "0";
671	return ($self);
672    }
673
674
675    if (ref($value) =~ m/ARRAY|HASH/) {
676	require Carp;
677	Carp::croak("Invalid version format (non-numeric data)");
678    }
679
680    $value = _un_vstring($value);
681
682    if ($Config{d_setlocale}) {
683	use POSIX qw/locale_h/;
684	use if $Config{d_setlocale}, 'locale';
685	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	if ( localeconv()->{decimal_point} eq ',' ) {
691	    $value =~ tr/,/./;
692	}
693    }
694
695    # exponential notation
696    if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
697	$value = sprintf("%.9f",$value);
698	$value =~ s/(0+)$//; # trim trailing zeros
699    }
700
701    my $s = scan_version($value, \$self, $qv);
702
703    if ($s) { # must be something left over
704	warn(sprintf "Version string '%s' contains invalid data; "
705		   ."ignoring: '%s'", $value, $s);
706    }
707
708    return ($self);
709}
710
711*parse = \&new;
712
713sub numify {
714    my ($self) = @_;
715    unless (_verify($self)) {
716	require Carp;
717	Carp::croak("Invalid version object");
718    }
719    my $alpha = $self->{alpha} || "";
720    my $len = $#{$self->{version}};
721    my $digit = $self->{version}[0];
722    my $string = sprintf("%d.", $digit );
723
724    if ($alpha and warnings::enabled()) {
725	warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy');
726    }
727
728    for ( my $i = 1 ; $i <= $len ; $i++ ) {
729	$digit = $self->{version}[$i];
730	$string .= sprintf("%03d", $digit);
731    }
732
733    if ( $len == 0 ) {
734	$string .= sprintf("000");
735    }
736
737    return $string;
738}
739
740sub normal {
741    my ($self) = @_;
742    unless (_verify($self)) {
743	require Carp;
744	Carp::croak("Invalid version object");
745    }
746
747    my $len = $#{$self->{version}};
748    my $digit = $self->{version}[0];
749    my $string = sprintf("v%d", $digit );
750
751    for ( my $i = 1 ; $i <= $len ; $i++ ) {
752	$digit = $self->{version}[$i];
753	$string .= sprintf(".%d", $digit);
754    }
755
756    if ( $len <= 2 ) {
757	for ( $len = 2 - $len; $len != 0; $len-- ) {
758	    $string .= sprintf(".%0d", 0);
759	}
760    }
761
762    return $string;
763}
764
765sub stringify {
766    my ($self) = @_;
767    unless (_verify($self)) {
768	require Carp;
769	Carp::croak("Invalid version object");
770    }
771    return exists $self->{original}
772    	? $self->{original}
773	: exists $self->{qv}
774	    ? $self->normal
775	    : $self->numify;
776}
777
778sub vcmp {
779    my ($left,$right,$swap) = @_;
780    die "Usage: version::vcmp(lobj, robj, ...)" if @_ < 2;
781    my $class = ref($left);
782    unless ( UNIVERSAL::isa($right, $class) ) {
783	$right = $class->new($right);
784    }
785
786    if ( $swap ) {
787	($left, $right) = ($right, $left);
788    }
789    unless (_verify($left)) {
790	require Carp;
791	Carp::croak("Invalid version object");
792    }
793    unless (_verify($right)) {
794	require Carp;
795	Carp::croak("Invalid version format");
796    }
797    my $l = $#{$left->{version}};
798    my $r = $#{$right->{version}};
799    my $m = $l < $r ? $l : $r;
800    my $lalpha = $left->is_alpha;
801    my $ralpha = $right->is_alpha;
802    my $retval = 0;
803    my $i = 0;
804    while ( $i <= $m && $retval == 0 ) {
805	$retval = $left->{version}[$i] <=> $right->{version}[$i];
806	$i++;
807    }
808
809    # possible match except for trailing 0's
810    if ( $retval == 0 && $l != $r ) {
811	if ( $l < $r ) {
812	    while ( $i <= $r && $retval == 0 ) {
813		if ( $right->{version}[$i] != 0 ) {
814		    $retval = -1; # not a match after all
815		}
816		$i++;
817	    }
818	}
819	else {
820	    while ( $i <= $l && $retval == 0 ) {
821		if ( $left->{version}[$i] != 0 ) {
822		    $retval = +1; # not a match after all
823		}
824		$i++;
825	    }
826	}
827    }
828
829    return $retval;
830}
831
832sub vbool {
833    my ($self) = @_;
834    return vcmp($self,$self->new("0"),1);
835}
836
837sub vnoop {
838    require Carp;
839    Carp::croak("operation not supported with version object");
840}
841
842sub is_alpha {
843    my ($self) = @_;
844    return (exists $self->{alpha});
845}
846
847sub qv {
848    my $value = shift;
849    my $class = $CLASS;
850    if (@_) {
851	$class = ref($value) || $value;
852	$value = shift;
853    }
854
855    $value = _un_vstring($value);
856    $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
857    my $obj = $CLASS->new($value);
858    return bless $obj, $class;
859}
860
861*declare = \&qv;
862
863sub is_qv {
864    my ($self) = @_;
865    return (exists $self->{qv});
866}
867
868
869sub _verify {
870    my ($self) = @_;
871    if ( ref($self)
872	&& eval { exists $self->{version} }
873	&& ref($self->{version}) eq 'ARRAY'
874	) {
875	return 1;
876    }
877    else {
878	return 0;
879    }
880}
881
882sub _is_non_alphanumeric {
883    my $s = shift;
884    $s = new charstar $s;
885    while ($s) {
886	return 0 if isSPACE($s); # early out
887	return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
888	$s++;
889    }
890    return 0;
891}
892
893sub _un_vstring {
894    my $value = shift;
895    # may be a v-string
896    if ( length($value) >= 1 && $value !~ /[,._]/
897	&& _is_non_alphanumeric($value)) {
898	my $tvalue;
899	if ( $] >= 5.008_001 ) {
900	    $tvalue = _find_magic_vstring($value);
901	    $value = $tvalue if length $tvalue;
902	}
903	elsif ( $] >= 5.006_000 ) {
904	    $tvalue = sprintf("v%vd",$value);
905	    if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) {
906		# must be a v-string
907		$value = $tvalue;
908	    }
909	}
910    }
911    return $value;
912}
913
914sub _find_magic_vstring {
915    my $value = shift;
916    my $tvalue = '';
917    require B;
918    my $sv = B::svref_2object(\$value);
919    my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
920    while ( $magic ) {
921	if ( $magic->TYPE eq 'V' ) {
922	    $tvalue = $magic->PTR;
923	    $tvalue =~ s/^v?(.+)$/v$1/;
924	    last;
925	}
926	else {
927	    $magic = $magic->MOREMAGIC;
928	}
929    }
930    $tvalue =~ tr/_//d;
931    return $tvalue;
932}
933
934sub _VERSION {
935    my ($obj, $req) = @_;
936    my $class = ref($obj) || $obj;
937
938    no strict 'refs';
939    if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
940	 # file but no package
941	require Carp;
942	Carp::croak( "$class defines neither package nor VERSION"
943	    ."--version check failed");
944    }
945
946    my $version = eval "\$$class\::VERSION";
947    if ( defined $version ) {
948	local $^W if $] <= 5.008;
949	$version = version::vpp->new($version);
950    }
951
952    if ( defined $req ) {
953	unless ( defined $version ) {
954	    require Carp;
955	    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	    if ( $ENV{VERSION_DEBUG} ) {
961		Carp::confess($msg);
962	    }
963	    else {
964		Carp::croak($msg);
965	    }
966	}
967
968	$req = version::vpp->new($req);
969
970	if ( $req > $version ) {
971	    require Carp;
972	    if ( $req->is_qv ) {
973		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		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    return defined $version ? $version->stringify : undef;
990}
991
9921; #this line is important and will help the module return a true value
993