AFS

 view release on metacpan or  search on metacpan

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

		}
		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 {

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

		$s = ++$pos;
	    }
	    elsif ( isDIGIT($pos) ) {
		$s = $pos;
	    }
	    else {
		$s = $pos;
		last;
	    }
	    if ( $qv ) {
		while ( isDIGIT($pos) ) {
		    $pos++;
		}
	    }
	    else {
		my $digits = 0;
		while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
		    if ( $pos ne '_' ) {
			$digits++;
		    }
		    $pos++;
		}
	    }
	}
    }
    if ( $qv ) { # quoted versions always get at least three terms
	my $len = $#av;
	#  This for loop appears to trigger a compiler bug on OS X, as it
	#  loops infinitely. Yes, len is negative. No, it makes no sense.
	#  Compiler in question is:
	#  gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
	#  for ( len = 2 - len; len > 0; len-- )
	#  av_push(MUTABLE_AV(sv), newSViv(0));
	#
	$len = 2 - $len;
	while ($len-- > 0) {
	    push @av, 0;
	}
    }

    # need to save off the current version string for later
    if ( $vinf ) {
	$$rv->{original} = "v.Inf";
	$$rv->{vinf} = 1;
    }
    elsif ( $s > $start ) {
	$$rv->{original} = $start->currstr($s);
	if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
	    # need to insert a v to be consistent
	    $$rv->{original} = 'v' . $$rv->{original};
	}
    }
    else {
	$$rv->{original} = '0';
	push(@av, 0);
    }

    # And finally, store the AV in the hash
    $$rv->{version} = \@av;

    # fix RT#19517 - special case 'undef' as string
    if ($s eq 'undef') {
	$s += 5;
    }

    return $s;
}

sub new
{
	my ($class, $value) = @_;
	my $self = bless ({}, ref ($class) || $class);
	my $qv = FALSE;

	if ( ref($value) && eval('$value->isa("version")') ) {
	    # Can copy the elements directly
	    $self->{version} = [ @{$value->{version} } ];
	    $self->{qv} = 1 if $value->{qv};
	    $self->{alpha} = 1 if $value->{alpha};
	    $self->{original} = ''.$value->{original};
	    return $self;
	}

	my $currlocale = setlocale(LC_ALL);

	# if the current locale uses commas for decimal points, we
	# just replace commas with decimal places, rather than changing
	# locales
	if ( localeconv()->{decimal_point} eq ',' ) {
	    $value =~ tr/,/./;
	}

	if ( not defined $value or $value =~ /^undef$/ ) {
	    # RT #19517 - special case for undef comparison
	    # or someone forgot to pass a value
	    push @{$self->{version}}, 0;
	    $self->{original} = "0";
	    return ($self);
	}

	if ( $#_ == 2 ) { # must be CVS-style
	    $value = $_[2];
	    $qv = TRUE;
	}

	$value = _un_vstring($value);

	# exponential notation
	if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
	    $value = sprintf("%.9f",$value);
	    $value =~ s/(0+)$//; # trim trailing zeros
	}

	my $s = scan_version($value, \$self, $qv);

	if ($s) { # must be something left over
	    warn("Version string '%s' contains invalid data; "
                       ."ignoring: '%s'", $value, $s);
	}

	return ($self);
}

*parse = \&new;

sub numify
{
    my ($self) = @_;
    unless (_verify($self)) {
	require Carp;
	Carp::croak("Invalid version object");
    }
    my $width = $self->{width} || 3;
    my $alpha = $self->{alpha} || "";
    my $len = $#{$self->{version}};
    my $digit = $self->{version}[0];
    my $string = sprintf("%d.", $digit );

    for ( my $i = 1 ; $i < $len ; $i++ ) {
	$digit = $self->{version}[$i];
	if ( $width < 3 ) {
	    my $denom = 10**(3-$width);
	    my $quot = int($digit/$denom);
	    my $rem = $digit - ($quot * $denom);
	    $string .= sprintf("%0".$width."d_%d", $quot, $rem);
	}
	else {
	    $string .= sprintf("%03d", $digit);
	}
    }

    if ( $len > 0 ) {
	$digit = $self->{version}[$len];
	if ( $alpha && $width == 3 ) {

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

}

*declare = \&qv;

sub is_qv {
    my ($self) = @_;
    return (exists $self->{qv});
}


sub _verify {
    my ($self) = @_;
    if ( ref($self)
	&& eval { exists $self->{version} }
	&& ref($self->{version}) eq 'ARRAY'
	) {
	return 1;
    }
    else {
	return 0;
    }
}

sub _is_non_alphanumeric {
    my $s = shift;
    $s = new charstar $s;
    while ($s) {
	return 0 if isSPACE($s); # early out
	return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
	$s++;
    }
    return 0;
}

sub _un_vstring {
    my $value = shift;
    # may be a v-string
    if ( length($value) >= 3 && $value !~ /[._]/
	&& _is_non_alphanumeric($value)) {
	my $tvalue;
	if ( $] ge 5.008_001 ) {
	    $tvalue = _find_magic_vstring($value);
	    $value = $tvalue if length $tvalue;
	}
	elsif ( $] ge 5.006_000 ) {
	    $tvalue = sprintf("v%vd",$value);
	    if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
		# must be a v-string
		$value = $tvalue;
	    }
	}
    }
    return $value;
}

sub _find_magic_vstring {
    my $value = shift;
    my $tvalue = '';
    require B;
    my $sv = B::svref_2object(\$value);
    my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
    while ( $magic ) {
	if ( $magic->TYPE eq 'V' ) {
	    $tvalue = $magic->PTR;
	    $tvalue =~ s/^v?(.+)$/v$1/;
	    last;
	}
	else {
	    $magic = $magic->MOREMAGIC;
	}
    }
    return $tvalue;
}

sub _VERSION {
    my ($obj, $req) = @_;
    my $class = ref($obj) || $obj;

    no strict 'refs';
    if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
	 # file but no package
	require Carp;
	Carp::croak( "$class defines neither package nor VERSION"
	    ."--version check failed");
    }

    my $version = eval "\$$class\::VERSION";
    if ( defined $version ) {
	local $^W if $] <= 5.008;
	$version = version::vpp->new($version);
    }

    if ( defined $req ) {
	unless ( defined $version ) {
	    require Carp;
	    my $msg =  $] < 5.006
	    ? "$class version $req required--this is only version "
	    : "$class does not define \$$class\::VERSION"
	      ."--version check failed";

	    if ( $ENV{VERSION_DEBUG} ) {
		Carp::confess($msg);
	    }
	    else {
		Carp::croak($msg);
	    }
	}

	$req = version::vpp->new($req);

	if ( $req > $version ) {
	    require Carp;
	    if ( $req->is_qv ) {
		Carp::croak(
		    sprintf ("%s version %s required--".
			"this is only version %s", $class,
			$req->normal, $version->normal)
		);
	    }
	    else {
		Carp::croak(
		    sprintf ("%s version %s required--".
			"this is only version %s", $class,
			$req->stringify, $version->stringify)
		);
	    }
	}
    }

    return defined $version ? $version->stringify : undef;
}

1; #this line is important and will help the module return a true value