AFS

 view release on metacpan or  search on metacpan

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

package charstar;
# a little helper class to emulate C char* semantics in Perl
# so that prescan_version can use the same code as in C

use overload (
    '""'	=> \&thischar,
    '0+'	=> \&thischar,
    '++'	=> \&increment,
    '--'	=> \&decrement,
    '+'		=> \&plus,
    '-'		=> \&minus,
    '*'		=> \&multiply,
    'cmp'	=> \&cmp,
    '<=>'	=> \&spaceship,
    'bool'	=> \&thischar,
    '='		=> \&clone,
);

sub new {
    my ($self, $string) = @_;
    my $class = ref($self) || $self;

    my $obj = {
	string  => [split(//,$string)],
	current => 0,
    };
    return bless $obj, $class;
}

sub thischar {
    my ($self) = @_;
    my $last = $#{$self->{string}};
    my $curr = $self->{current};
    if ($curr >= 0 && $curr <= $last) {
	return $self->{string}->[$curr];
    }
    else {
	return '';
    }
}

sub increment {
    my ($self) = @_;
    $self->{current}++;
}

sub decrement {
    my ($self) = @_;
    $self->{current}--;
}

sub plus {
    my ($self, $offset) = @_;
    my $rself = $self->clone;
    $rself->{current} += $offset;
    return $rself;
}

sub minus {
    my ($self, $offset) = @_;
    my $rself = $self->clone;
    $rself->{current} -= $offset;
    return $rself;
}

sub multiply {
    my ($left, $right, $swapped) = @_;
    my $char = $left->thischar();
    return $char * $right;
}

sub spaceship {
    my ($left, $right, $swapped) = @_;
    unless (ref($right)) { # not an object already
	$right = $left->new($right);
    }
    return $left->{current} <=> $right->{current};
}

sub cmp {
    my ($left, $right, $swapped) = @_;
    unless (ref($right)) { # not an object already
	if (length($right) == 1) { # comparing single character only
	    return $left->thischar cmp $right;
	}
	$right = $left->new($right);
    }
    return $left->currstr cmp $right->currstr;
}

sub bool {
    my ($self) = @_;
    my $char = $self->thischar;
    return ($char ne '');
}

sub clone {
    my ($left, $right, $swapped) = @_;
    $right = {
	string  => [@{$left->{string}}],
	current => $left->{current},
    };
    return bless $right, ref($left);
}

sub currstr {
    my ($self, $s) = @_;
    my $curr = $self->{current};
    my $last = $#{$self->{string}};
    if (defined($s) && $s->{current} < $last) {
	$last = $s->{current};
    }

    my $string = join('', @{$self->{string}}[$curr..$last]);
    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/);
}

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

		    $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");
    }

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

	&& $left->{version}[$m] == $right->{version}[$m]
	&& ( $lalpha || $ralpha ) ) {

	if ( $lalpha && !$ralpha ) {
	    $retval = -1;
	}
	elsif ( $ralpha && !$lalpha) {
	    $retval = +1;
	}
    }

    # possible match except for trailing 0's
    if ( $retval == 0 && $l != $r ) {
	if ( $l < $r ) {
	    while ( $i <= $r && $retval == 0 ) {
		if ( $right->{version}[$i] != 0 ) {
		    $retval = -1; # not a match after all
		}
		$i++;
	    }
	}
	else {
	    while ( $i <= $l && $retval == 0 ) {
		if ( $left->{version}[$i] != 0 ) {
		    $retval = +1; # not a match after all
		}
		$i++;
	    }
	}
    }

    return $retval;
}

sub vbool {
    my ($self) = @_;
    return vcmp($self,$self->new("0"),1);
}

sub vnoop {
    require Carp;
    Carp::croak("operation not supported with version object");
}

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

sub qv {
    my $value = shift;
    my $class = 'version';
    if (@_) {
	$class = ref($value) || $value;
	$value = shift;
    }

    $value = _un_vstring($value);
    $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
    my $obj = version->new($value);
    return bless $obj, $class;
}

*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);