File Coverage

blib/lib/URI/PackageURL.pm

Criterion	Covered	Total	%
statement	120	125	96.0
branch	50	56	89.2
condition	6	9	66.6
subroutine	22	24	91.6
pod	12	16	75.0
total	210	230	91.3

package URI::PackageURL;

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

use Exporter qw(import);

use constant DEBUG => $ENV{PURL_DEBUG};

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

our $VERSION = '1.02';

our @EXPORT = qw(encode_purl decode_purl);

sub encode_purl {

    my (%components) = @_;

    my $purl = URI::PackageURL->new(%components);
    return $purl->to_string;

}

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

sub new {

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

    Carp::croak "Invalid PackageURL: 'type' component is required" if (!defined $components{type});
    Carp::croak "Invalid PackageURL: 'name' component is required" if (!defined $components{name});

    my $self = bless normalize_components(%components), $class;

    return $self;

}

sub scheme     { shift->{scheme} || 'pkg' }
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 normalize_components {

    my (%components) = @_;

    $components{type} = lc $components{type};

    if ($components{type} eq 'pypi') {
        $components{name} =~ s/_/-/g;
    }

    # CPAN: Split Perl "Namespace::Package" naming into "namespace" and "name" components
    if ($components{type} eq 'cpan' && $components{name} =~ /::/) {

        my @ns   = split /::/, $components{name};
        my $name = pop @ns;

        $components{name}      = $name;
        $components{namespace} = join '::', @ns;

    }

    if (grep { $_ eq $components{type} } qw(bitbucket deb github golang hex npm pypi)) {
        $components{name} = lc $components{name};
    }


    # Checks

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

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

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

    if ($components{type} eq 'conan') {

        if (defined $components{namespace} && $components{namespace} ne '') {

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

        }
        else {

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

        }

    }

    return \%components;

}

sub from_string {

    my ($class, $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]);


    # 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) = @_;

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

sub TO_JSON {

    my ($self) = @_;

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

}

1;
__END__