File Coverage

blib/lib/URI/PackageURL.pm

Criterion	Covered	Total	%
statement	124	127	97.6
branch	55	60	91.6
condition	7	10	70.0
subroutine	23	24	95.8
pod	13	14	92.8
total	222	235	94.4

package URI::PackageURL;

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

use Carp;
use Exporter              qw(import);
use URI::PackageURL::Util qw(purl_to_urls);

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

our $VERSION = '2.02';
our @EXPORT  = qw(encode_purl decode_purl);

my $PURL_REGEXP = qr{^pkg:[A-Za-z\\.\\-\\+][A-Za-z0-9\\.\\-\\+]*/.+};

sub new {

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

    my $scheme     = delete $params{scheme} // 'pkg';
    my $type       = delete $params{type} or Carp::croak "Invalid PackageURL: 'type' component is required";
    my $namespace  = delete $params{namespace};
    my $name       = delete $params{name} or Carp::croak "Invalid PackageURL: 'name' component is required";
    my $version    = delete $params{version};
    my $qualifiers = delete $params{qualifiers} // {};
    my $subpath    = delete $params{subpath};

    $type = lc $type;

    if (grep { $_ eq $type } qw(alpm apk bitbucket composer deb github gitlab hex npm oci pypi)) {
        $name = lc $name;
    }

    if ($namespace) {
        if (grep { $_ eq $type } qw(alpm apk bitbucket composer deb github gitlab golang hex rpm)) {
            $namespace = lc $namespace;
        }
    }

    foreach my $qualifier (keys %{$qualifiers}) {
        Carp::croak "Invalid PackageURL: '$qualifier' is not a valid qualifier" if ($qualifier =~ /\s/);
    }

    $name =~ s/_/-/g  if $type eq 'pypi';
    $name =~ s/::/-/g if $type eq 'cpan';

    if ($type eq 'swift') {
        Carp::croak "Invalid PackageURL: Swift 'version' is required"   unless defined $version;
        Carp::croak "Invalid PackageURL: Swift 'namespace' is required" unless defined $namespace;
    }

    if ($type eq 'cran') {
        Carp::croak "Invalid PackageURL: Cran 'version' is required" unless defined $version;
    }

    if ($type eq 'conan') {

        if ($namespace && $namespace ne '') {
            if (!defined $qualifiers->{channel}) {
                Carp::croak "Invalid PackageURL: Conan 'channel' qualifier does not exist for namespace '$namespace'";
            }
        }
        else {
            if (defined $qualifiers->{channel}) {
                Carp::croak "Invalid PackageURL: Conan 'namespace' does not exist for channel '$qualifiers->{channel}'";
            }
        }

    }

    my $self = {
        scheme     => $scheme,
        type       => $type,
        namespace  => $namespace,
        name       => $name,
        version    => $version,
        qualifiers => $qualifiers,
        subpath    => $subpath
    };

    return bless $self, $class;

}

sub scheme     { shift->{scheme} }
sub type       { shift->{type} }
sub namespace  { shift->{namespace} }
sub name       { shift->{name} }
sub version    { shift->{version} }
sub qualifiers { shift->{qualifiers} }
sub subpath    { shift->{subpath} }

sub encode_purl {
    return URI::PackageURL->new(@_)->to_string;
}

sub decode_purl {
    return URI::PackageURL->from_string(shift);
}

sub from_string {

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

    if ($string !~ /$PURL_REGEXP/) {
        Carp::croak 'Malformed PackageURL string';
    }

    my %components = ();


    # Split the purl string once from right on '#'
    #     The left side is the remainder
    #     Strip the right side from leading and trailing '/'
    #     Split this on '/'
    #     Discard any empty string segment from that split
    #     Discard any '.' or '..' segment from that split
    #     Percent-decode each segment
    #     UTF-8-decode each segment if needed in your programming language
    #     Join segments back with a '/'
    #     This is the subpath

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

    if ($s1[1]) {
        $s1[1] =~ s{(^\/|\/$)}{};
        my @subpath = map { _url_decode($_) } grep { $_ ne '' && $_ ne '.' && $_ ne '..' } split /\//, $s1[1];
        $components{subpath} = join '/', @subpath;
    }

    # Split the remainder once from right on '?'
    #     The left side is the remainder
    #     The right side is the qualifiers string
    #     Split the qualifiers on '&'. Each part is a key=value pair
    #     For each pair, split the key=value once from left on '=':
    #         The key is the lowercase left side
    #         The value is the percent-decoded right side
    #         UTF-8-decode the value if needed in your programming language
    #         Discard any key/value pairs where the value is empty
    #         If the key is checksums, split the value on ',' to create a list of checksums
    #     This list of key/value is the qualifiers object

    my @s2 = split(/\?/, $s1[0]);

    if ($s2[1]) {

        my @qualifiers = split('&', $s2[1]);

        foreach my $qualifier (@qualifiers) {

            my ($key, $value) = split('=', $qualifier);
            $value = _url_decode($value);

            if ($key eq 'checksums') {
                $value = [split(',', $value)];
            }

            $components{qualifiers}->{$key} = $value;

        }

    }


    # Split the remainder once from left on ':'
    #     The left side lowercased is the scheme
    #     The right side is the remainder

    my @s3 = split(':', $s2[0], 2);
    $components{scheme} = lc $s3[0];


    # Strip the remainder from leading and trailing '/'
    #     Split this once from left on '/'
    #     The left side lowercased is the type
    #     The right side is the remainder

    $s3[1] =~ s{(^\/|\/$)}{};
    my @s4 = split('/', $s3[1], 2);
    $components{type} = lc $s4[0];


    # Split the remainder once from right on '@'
    #     The left side is the remainder
    #     Percent-decode the right side. This is the version.
    #     UTF-8-decode the version if needed in your programming language
    #     This is the version

    my @s5 = split('@', $s4[1]);
    $components{version} = _url_decode($s5[1]) if ($s5[1]);


    # Split the remainder once from right on '/'
    #     The left side is the remainder
    #     Percent-decode the right side. This is the name
    #     UTF-8-decode this name if needed in your programming language
    #     Apply type-specific normalization to the name if needed
    #     This is the name

    my @s6 = split('/', $s5[0], 2);
    $components{name} = (scalar @s6 > 1) ? _url_decode($s6[1]) : _url_decode($s6[0]);


    # Split the remainder on '/'
    #     Discard any empty segment from that split
    #     Percent-decode each segment
    #     UTF-8-decode the each segment if needed in your programming language
    #     Apply type-specific normalization to each segment if needed
    #     Join segments back with a '/'
    #     This is the namespace

    if (scalar @s6 > 1) {
        my @s7 = split('/', $s6[0]);
        $components{namespace} = join '/', map { _url_decode($_) } @s7;
    }

    return $class->new(%components);

}

sub to_string {

    my $self = shift;

    my @purl = ('pkg', ':', $self->type, '/');

    # Namespace
    if ($self->namespace) {

        my @ns = map { _url_encode($_) } split(/\//, $self->namespace);
        push @purl, (join('/', @ns), '/');

    }

    # Name
    push @purl, _url_encode($self->name);

    # Version
    push @purl, ('@', _url_encode($self->version)) if ($self->version);

    # Qualifiers
    if (my $qualifiers = $self->qualifiers) {

        my @qualifiers = map { sprintf('%s=%s', $_, _url_encode($qualifiers->{$_})) } sort keys %{$qualifiers};
        push @purl, ('?', join('&', @qualifiers)) if (@qualifiers);

    }

    # Subpath
    push @purl, ('#', $self->subpath) if ($self->subpath);

    return join '', @purl;

}

sub to_urls {
    purl_to_urls(shift);
}

sub TO_JSON {

    my $self = shift;

    return {
        type       => $self->type,
        name       => $self->name,
        version    => $self->version,
        namespace  => $self->namespace,
        qualifiers => $self->qualifiers,
        subpath    => $self->subpath,
    };

}

sub _url_encode {

    my $string = shift;

    # RFC-3986 (but exclude "/" and ":")
    $string =~ s/([^A-Za-z0-9\-._~\/:])/sprintf '%%%02X', ord $1/ge;
    return $string;

}

sub _url_decode {
    my $string = shift;
    $string =~ s/%([0-9a-fA-F]{2})/chr hex $1/ge;
    return $string;
}

1;

__END__