view release on metacpan or  search on metacpan

src/inc/version/vpp.pm  view on Meta::CPAN

    return $string;
}

package version::vpp;
use strict;

use POSIX qw/locale_h/;
use locale;
use vars qw ($VERSION @ISA @REGEXS);
$VERSION = 0.96;

use overload (
    '""'       => \&stringify,
    '0+'       => \&numify,
    'cmp'      => \&vcmp,
    '<=>'      => \&vcmp,
    'bool'     => \&vbool,
    '+'        => \&vnoop,
    '-'        => \&vnoop,
    '*'        => \&vnoop,
    '/'        => \&vnoop,
    '+='        => \&vnoop,
    '-='        => \&vnoop,
    '*='        => \&vnoop,
    '/='        => \&vnoop,
    'abs'      => \&vnoop,
);

eval "use warnings";
if ($@) {
    eval '
	package
	warnings;
	sub enabled {return $^W;}
	1;
    ';
}

my $VERSION_MAX = 0x7FFFFFFF;

# implement prescan_version as closely to the C version as possible
use constant TRUE  => 1;
use constant FALSE => 0;

sub isDIGIT {
    my ($char) = shift->thischar();
    return ($char =~ /\d/);
}

sub isALPHA {
    my ($char) = shift->thischar();
    return ($char =~ /[a-zA-Z]/);
}

sub isSPACE {
    my ($char) = shift->thischar();
    return ($char =~ /\s/);
}

sub BADVERSION {
    my ($s, $errstr, $error) = @_;
    if ($errstr) {
	$$errstr = $error;
    }
    return $s;
}

sub prescan_version {
    my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
    my $qv          = defined $sqv          ? $$sqv          : FALSE;
    my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
    my $width       = defined $swidth       ? $$swidth       : 3;
    my $alpha       = defined $salpha       ? $$salpha       : FALSE;

    my $d = $s;

    if ($qv && isDIGIT($d)) {
	goto dotted_decimal_version;
    }

    if ($d eq 'v') { # explicit v-string
	$d++;
	if (isDIGIT($d)) {
	    $qv = TRUE;
	}
	else { # degenerate v-string
	    # requires v1.2.3
	    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
	}

dotted_decimal_version:
	if ($strict && $d eq '0' && isDIGIT($d+1)) {
	    # no leading zeros allowed
	    return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
	}

	while (isDIGIT($d)) { 	# integer part
	    $d++;
	}

	if ($d eq '.')
	{
	    $saw_decimal++;
	    $d++; 		# decimal point
	}
	else
	{
	    if ($strict) {
		# require v1.2.3
		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
	    }
	    else {
		goto version_prescan_finish;
	    }
	}

	{
	    my $i = 0;
	    my $j = 0;
	    while (isDIGIT($d)) {	# just keep reading
		$i++;
		while (isDIGIT($d)) {
		    $d++; $j++;
		    # maximum 3 digits between decimal
		    if ($strict && $j > 3) {
			return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
		    }
		}
		if ($d eq '_') {
		    if ($strict) {
			return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
		    }
		    if ( $alpha ) {
			return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
		    }
		    $d++;
		    $alpha = TRUE;
		}
		elsif ($d eq '.') {
		    if ($alpha) {
			return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
		    }
		    $saw_decimal++;
		    $d++;
		}
		elsif (!isDIGIT($d)) {
		    last;
		}
		$j = 0;
	    }

	    if ($strict && $i < 2) {
		# requires v1.2.3
		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
	    }
	}
    } 					# end if dotted-decimal
    else
    {					# decimal versions
	# special $strict case for leading '.' or '0'
	if ($strict) {
	    if ($d eq '.') {
		return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
	    }
	    if ($d eq '0' && isDIGIT($d+1)) {
		return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
	    }
	}

	# and we never support negative version numbers
	if ($d eq '-') {
	    return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
	}

	# consume all of the integer part
	while (isDIGIT($d)) {
	    $d++;
	}

	# look for a fractional part
	if ($d eq '.') {
	    # we found it, so consume it
	    $saw_decimal++;
	    $d++;
	}
	elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
	    if ( $d == $s ) {
		# found nothing
		return BADVERSION($s,$errstr,"Invalid version format (version required)");
	    }
	    # found just an integer
	    goto version_prescan_finish;
	}
	elsif ( $d == $s ) {
	    # didn't find either integer or period
	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
	}
	elsif ($d eq '_') {
	    # underscore can't come after integer part
	    if ($strict) {
		return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
	    }
	    elsif (isDIGIT($d+1)) {
		return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
	    }
	    else {
		return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
	    }
	}
	elsif ($d) {
	    # anything else after integer part is just invalid data
	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
	}

	# scan the fractional part after the decimal point
	if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
		# $strict or lax-but-not-the-end
		return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
	}

	while (isDIGIT($d)) {
	    $d++;
	    if ($d eq '.' && isDIGIT($d-1)) {
		if ($alpha) {
		    return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
		}
		if ($strict) {
		    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
		}
		$d = $s; # start all over again
		$qv = TRUE;
		goto dotted_decimal_version;
	    }
	    if ($d eq '_') {
		if ($strict) {
		    return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
		}
		if ( $alpha ) {
		    return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
		}
		if ( ! isDIGIT($d+1) ) {
		    return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
		}
		$d++;
		$alpha = TRUE;
	    }
	}
    }

version_prescan_finish:
    while (isSPACE($d)) {
	$d++;
    }

    if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
	# trailing non-numeric data
	return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
    }

    if (defined $sqv) {
	$$sqv = $qv;
    }
    if (defined $swidth) {
	$$swidth = $width;
    }
    if (defined $ssaw_decimal) {
	$$ssaw_decimal = $saw_decimal;
    }
    if (defined $salpha) {
	$$salpha = $alpha;
    }
    return $d;
}

sub scan_version {
    my ($s, $rv, $qv) = @_;
    my $start;
    my $pos;
    my $last;
    my $errstr;
    my $saw_decimal = 0;
    my $width = 3;
    my $alpha = FALSE;
    my $vinf = FALSE;
    my @av;

    $s = new charstar $s;

    while (isSPACE($s)) { # leading whitespace is OK
	$s++;
    }

    $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
	\$width, \$alpha);

    if ($errstr) {
	# 'undef' is a special case and not an error
	if ( $s ne 'undef') {
	    use Carp;
	    Carp::croak($errstr);
	}
    }

    $start = $s;
    if ($s eq 'v') {
	$s++;
    }
    $pos = $s;

    if ( $qv ) {
	$$rv->{qv} = $qv;
    }
    if ( $alpha ) {
	$$rv->{alpha} = $alpha;
    }
    if ( !$qv && $width < 3 ) {
	$$rv->{width} = $width;
    }

    while (isDIGIT($pos)) {
	$pos++;
    }
    if (!isALPHA($pos)) {
	my $rev;

	for (;;) {
	    $rev = 0;
	    {
  		# this is atoi() that delimits on underscores
  		my $end = $pos;
  		my $mult = 1;
		my $orev;

		#  the following if() will only be true after the decimal
		#  point of a version originally created with a bare
		#  floating point number, i.e. not quoted in any way
		#
 		if ( !$qv && $s > $start && $saw_decimal == 1 ) {
		    $mult *= 100;
 		    while ( $s < $end ) {
			$orev = $rev;
 			$rev += $s * $mult;
 			$mult /= 10;
			if (   (abs($orev) > abs($rev))
			    || (abs($rev) > $VERSION_MAX )) {
			    warn("Integer overflow in version %d",
					   $VERSION_MAX);
			    $s = $end - 1;
			    $rev = $VERSION_MAX;
			    $vinf = 1;
			}
 			$s++;
			if ( $s eq '_' ) {
			    $s++;
			}
 		    }
  		}
 		else {
 		    while (--$end >= $s) {
			$orev = $rev;