File Coverage

blib/lib/URI/VersionRange.pm

Criterion	Covered	Total	%
statement	146	147	99.3
branch	44	54	81.4
condition	23	27	85.1
subroutine	37	37	100.0
pod	12	12	100.0
total	262	277	94.5

package URI::VersionRange;

use feature ':5.10';
use strict;
use utf8;
use warnings;

use Carp       ();
use List::Util qw(first);
use Exporter   qw(import);

use URI::VersionRange::Constraint;
use URI::VersionRange::Util qw(native_range_to_vers version_compare);
use URI::VersionRange::Version;

use constant DEBUG => $ENV{VERS_DEBUG};
use constant TRUE  => !!1;
use constant FALSE => !!0;

use overload '""' => 'to_string', fallback => 1;

BEGIN { *VERS:: = *URI::VersionRange:: }

our $VERSION = '2.25';
our @EXPORT  = qw(encode_vers decode_vers);

my $VERS_REGEXP = qr{^vers:[a-z\\.\\-\\+][a-z0-9\\.\\-\\+]*/.+};

sub new {

    my ($class, %params) = @_;

    my $scheme      = delete $params{scheme}      or Carp::croak "Invalid Version Range: 'scheme' is required";
    my $constraints = delete $params{constraints} or Carp::croak "Invalid Version Range: 'constraints' is required";

    my @constraints = ();

    foreach my $constraint (@{$constraints}) {

        if (ref($constraint) ne 'URI::VersionRange::Constraint') {
            $constraint = URI::VersionRange::Constraint->from_string($constraint);
        }

        push @constraints, $constraint;

    }

    $scheme = lc $scheme;

    my $scheme_class = URI::VersionRange::Version->load($scheme);

    my $self = {scheme => $scheme, constraints => \@constraints, scheme_class => $scheme_class};

    return bless $self, $class;

}

sub scheme      { shift->{scheme} }
sub constraints { shift->{constraints} }

sub encode_vers { __PACKAGE__->new(@_)->to_string }
sub decode_vers { __PACKAGE__->from_string(shift) }

sub from_native {

    my ($class, %params) = @_;

    my $scheme = delete $params{scheme} or Carp::croak "Invalid Version Range: 'scheme' is required";
    my $range  = delete $params{range}  or Carp::croak "Invalid Version Range: 'range' is required";

    my $vers = native_range_to_vers(lc $scheme, $range);
    return $class->from_string($vers);

}

sub from_string {

    my ($class, $string) = @_;

    if ($string !~ /$VERS_REGEXP/) {
        Carp::croak 'Malformed Version Range string';
    }

    if ($string =~ /^vers\:(none|all)\// && $string !~ /^vers\:(none|all)\/\*$/) {
        Carp::croak 'Malformed Version Range string';
    }

    my %params = ();

    # - Remove all spaces and tabs.
    # - Start from left, and split once on colon ":".
    # - The left hand side is the URI-scheme that must be lowercase.
    #       Tools must validate that the URI-scheme value is vers.
    # - The right hand side is the specifier.

    $string =~ s/(\s|\t)+//g;

    my @s1 = split(':', $string);

    # - Split the specifier from left once on a slash "/".
    # - The left hand side is the  that must be lowercase. Tools
    #   should validate that the  is a known scheme.
    # - The right hand side is a list of one or more constraints. Tools must validate
    #   that this constraints string is not empty ignoring spaces.

    my @s2 = split('/', $s1[1]);
    $params{scheme} = lc $s2[0];

    # - If the constraints string is equal to "", the ````
    #   is "". Parsing is done and no further processing is needed for this vers.
    #   A tool should report an error if there are extra characters beyond "*".
    # - Strip leading and trailing pipes "|" from the constraints string.
    # - Split the constraints on pipe "|". The result is a list of .
    #   Consecutive pipes must be treated as one and leading and trailing pipes ignored.

    $s2[1] =~ s/(^\|)|(\|$)//g;

    my @s3 = split(/\|/, $s2[1]);
    $params{constraints} = [];

    # - For each :
    #   - Determine if the  starts with one of the two comparators:
    #     - If it starts with ">=", then the comparator is ">=".
    #     - If it starts with "<=", then the comparator is "<=".
    #     - If it starts with "!=", then the comparator is "!=".
    #     - If it starts with "<", then the comparator is "<".
    #     - If it starts with ">", then the comparator is ">".
    #     - Remove the comparator from  string start. The remaining string is the version.
    #   - Otherwise the version is the full  string (which implies an equality comparator of "=")
    #   - Tools should validate and report an error if the version is empty.
    #   - If the version contains a percent "%" character, apply URL quoting rules to unquote this string.
    #   - Append the parsed (comparator, version) to the constraints list.

    foreach (@s3) {
        push @{$params{constraints}}, URI::VersionRange::Constraint->from_string($_);
    }

    if (DEBUG) {
        say STDERR "-- S1: @s1";
        say STDERR "-- S2: @s2";
        say STDERR "-- S3: @s3";
    }

    return $class->new(%params);

}

sub to_string {
    my $self        = shift;
    my @constraints = sort { version_compare($self->scheme, $a->version, $b->version) } @{$self->constraints};
    return join '', 'vers:', $self->scheme, '/', join('|', @constraints);
}

sub constraint_contains {

    my ($self, $constraint, $version) = @_;

    return TRUE if $constraint->comparator eq '*';

    my $version_class = $self->{scheme_class};

    my $v1 = $version_class->new($version);
    my $v2 = $version_class->new($constraint->version);

    return ($v1 == $v2) if ($constraint->comparator eq '=');
    return ($v1 != $v2) if ($constraint->comparator eq '!=');
    return ($v1 <= $v2) if ($constraint->comparator eq '<=');
    return ($v1 >= $v2) if ($constraint->comparator eq '>=');
    return ($v1 < $v2)  if ($constraint->comparator eq '<');
    return ($v1 > $v2)  if ($constraint->comparator eq '>');

    return FALSE;

}

sub contains {

    my ($self, $version) = @_;

    my @first  = ();
    my @second = ();

    my $version_class = $self->{scheme_class};

    if (scalar @{$self->constraints} == 1) {
        return $self->constraint_contains($self->constraints->[0], $version);
    }

    foreach my $constraint (@{$self->constraints}) {

        # If the "tested version" is equal to the any of the constraint version
        # where the constraint comparator is for equality (any of "=", "<=", or ">=")
        # then the "tested version" is in the range. Check is finished.

        return TRUE
            if ((first { $constraint->comparator eq $_ } ('=', '<=', '>='))
            && ($version_class->new($version) == $version_class->new($constraint->version)));

        # If the "tested version" is equal to the any of the constraint version
        # where the constraint comparator is "=!" then the "tested version" is NOT
        # in the range. Check is finished.

        return FALSE
            if ($constraint->comparator eq '!='
            && ($version_class->new($version) == $version_class->new($constraint->version)));

        # Split the constraint list in two sub lists:
        #    a first list where the comparator is "=" or "!="
        #    a second list where the comparator is neither "=" nor "!="

        push @first,  $constraint if ((first { $constraint->comparator eq $_ } ('=',  '!=')));
        push @second, $constraint if (!(first { $constraint->comparator eq $_ } ('=', '!=')));

    }

    return FALSE unless @second;

    if (scalar @second == 1) {
        return $self->constraint_contains($second[0], $version);
    }

    # Iterate over the current and next contiguous constraints pairs (aka. pairwise)
    # in the second list.

    # For each current and next constraint:

    my $is_first_iteration = TRUE;

    my $current_constraint = undef;
    my $next_constraint    = undef;

    foreach (_pairwise(@second)) {

        ($current_constraint, $next_constraint) = @{$_};

        DEBUG and say STDERR sprintf '-- Current constraint -->  %s', $current_constraint;
        DEBUG and say STDERR sprintf '-- Next constraint    -->  %s', $next_constraint;

        # If this is the first iteration and current comparator is "<" or <=" and
        # the "tested version" is less than the current version then the "tested
        # version" is IN the range. Check is finished.

        if ($is_first_iteration) {

            return TRUE
                if ((first { $current_constraint->comparator eq $_ } ('<=', '<'))
                && ($version_class->new($version) < $version_class->new($current_constraint->version)));

            $is_first_iteration = FALSE;

        }

        # If current comparator is ">" or >=" and next comparator is "<" or <="
        # and the "tested version" is greater than the current version and the
        # "tested version" is less than the next version then the "tested version"
        # is IN the range. Check is finished.

        if (   (first { $current_constraint->comparator eq $_ } ('>', '>='))
            && (first { $next_constraint->comparator eq $_ } ('<', '<='))
            && ($version_class->new($version) > $version_class->new($current_constraint->version))
            && ($version_class->new($version) < $version_class->new($next_constraint->version)))
        {
            return TRUE;
        }

        # If current comparator is "<" or <=" and next comparator is ">" or >="
        # then these versions are out the range. Continue to the next iteration.

        elsif ((first { $current_constraint->comparator eq $_ } ('<', '<='))
            && (first { $next_constraint->comparator } ('>', '>=')))
        {
            next;
        }

    }

    # If this is the last iteration and next comparator is ">" or >=" and the
    # "tested version" is greater than the next version then the "tested version"
    # is IN the range. Check is finished.

    return TRUE
        if ((first { $next_constraint->comparator eq $_ } ('>', '>='))
        && ($version_class->new($version) > $version_class->new($next_constraint->version)));

    return FALSE;

}

sub to_hash {
    return {scheme => $_[0]->scheme, constraints => $_[0]->constraints};
}

sub TO_JSON { shift->to_hash }

sub _pairwise {

    my @out = ();

    for (my $i = 0; $i < scalar @_; $i++) {
        push @out, [$_[$i], $_[$i + 1]] if $_[$i + 1];
    }

    return @out;

}

1;

__END__