File Coverage

blib/lib/URI/PackageURL.pm

Criterion	Covered	Total	%
statement	156	163	95.7
branch	44	54	81.4
condition	17	24	70.8
subroutine	31	34	91.1
pod	19	19	100.0
total	267	294	90.8

package URI::PackageURL;

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

use Carp     ();
use Exporter qw(import);

use URI::PackageURL::Type;
use URI::PackageURL::Util qw(purl_to_urls);

BEGIN { *PURL:: = *URI::PackageURL:: }

use constant DEBUG => $ENV{PURL_DEBUG};

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

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

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

sub new {

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

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

    my $validate = delete $params{validate} // 1;

    my $purl_definition = URI::PackageURL::Type->new($type);

    my %components = $purl_definition->normalize(
        scheme     => 'pkg',         # The scheme is a constant with the value "pkg".
        type       => $type,
        namespace  => $namespace,
        name       => $name,
        version    => $version,
        qualifiers => $qualifiers,
        subpath    => $subpath,
    );

    $purl_definition->validate(%components) if $validate;

    my $self = {components => \%components, definition => $purl_definition};

    return bless $self, $class;

}

sub definition { shift->{definition} }

sub scheme     {'pkg'}    # The scheme is a constant with the value "pkg".
sub type       { shift->_component('type',       @_) }
sub namespace  { shift->_component('namespace',  @_) }
sub name       { shift->_component('name',       @_) }
sub version    { shift->_component('version',    @_) }
sub qualifiers { shift->_component('qualifiers', @_) }
sub subpath    { shift->_component('subpath',    @_) }

sub encode_purl { __PACKAGE__->new(@_)->to_string }
sub decode_purl { __PACKAGE__->from_string(shift) }

sub clone {
    my $self = shift;
    bless {%$self}, ref $self;
}

sub to_urls        { purl_to_urls(shift) }
sub download_url   { shift->to_urls->{download} }
sub repository_url { shift->to_urls->{repository} }

sub from_string {

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

    DEBUG and say STDERR "-- INPUT: $string";
    DEBUG and say STDERR "-- REGEXP: $PURL_REGEXP";

    # Strip slash / after scheme
    while ($string =~ m{^pkg:/}) {
        $string =~ s{^pkg:/}{pkg:};
    }

    if ($string !~ /$PURL_REGEXP/) {
        Carp::croak 'Malformed PURL 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 'checksum', split the 'value' on ',' to create a list of checksum
    #     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) = ($qualifier =~ /^([^=]+)(?:=(.*))?$/);
            $value = _url_decode($value);

            if ($key eq 'checksums' || $key eq 'checksum') {
                Carp::carp "Detected 'checksums' qualifier. Use 'checksum' qualifier instead." if ($key eq 'checksums');
                $value = [split(',', $value)];
            }

            $components{qualifiers}->{lc $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);

    Carp::croak 'Invalid PURL: Missing "scheme"' unless $s3[0];
    Carp::croak 'Invalid PURL'                   unless $s3[1];

    $components{scheme} = lc $s3[0];

    # Strip all leading '/' characters (e.g., '/', '//', '///' and so on) from the 'remainder'
    #     Split this once from left on '/'
    #     The left side lowercased is the 'type'
    #     The right side is the 'remainder'

    while ($s3[1] =~ m|^//|) {
        $s3[1] =~ s|^//|/|;
    }

    $s3[1] =~ s|^/||;    # Strip leading '/' character

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

    Carp::croak 'Invalid PURL: Invalid "type"' if $components{type} !~ /^[a-z][a-z0-9.-]+$/;
    Carp::croak 'Invalid PURL' unless $s4[1];


    # 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]);

    # NPM purl MAY have a namespace starting with "@"
    # so we need to handle this case separately

    if ($components{type} eq 'npm' and $s4[1] =~ /^@/ and $s4[1] !~ /@.*@/) {
        @s5 = ($s4[1]);
    }

    $components{version} = _url_decode($s5[1]) if ($s5[1]);


    # Strip all trailing '/' characters (e.g., '/', '//', '///' and so on) from the 'remainder'
    #     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'

    while ($s5[0] =~ m|//$|) {
        $s5[0] =~ s|//$|/|;
    }

    $s5[0] =~ s|/$||;    # Strip trailing '/' character

    my @s6 = split('/', $s5[0], -1);
    $components{name} = _url_decode(pop @s6);

    Carp::croak 'Invalid PURL: Missing "name"' unless $components{name};


    # 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 (@s6) {
        $components{namespace} = join '/', map { _url_decode($_) } @s6;
    }


    if (DEBUG) {
        say STDERR "-- S1: @s1";
        say STDERR "-- S2: @s2";
        say STDERR "-- S3: @s3";
        say STDERR "-- S4: @s4";
        say STDERR "-- S5: @s5";
        say STDERR "-- S6: @s6";
    }

    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, _encode($self->name);

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

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

        # TODO: Legacy 'checksums' qualifier will be dropped in the future
        foreach (qw[checksum checksums]) {
            if (defined $qualifiers->{$_} && ref $qualifiers->{$_} eq 'ARRAY') {
                $qualifiers->{$_} = join ',', @{$qualifiers->{$_}};
            }
        }

        # TODO: Use URI::VersionRange during qualifiers decode ?
        if (defined $qualifiers->{vers} && ref $qualifiers->{vers} eq 'URI::VersionRange') {
            $qualifiers->{vers} = $qualifiers->{vers}->to_string;
            say STDERR $qualifiers->{vers};
        }

        my @qualifiers = map { sprintf('%s=%s', lc $_, _encode($qualifiers->{$_})) }
            grep { $qualifiers->{$_} } sort keys %{$qualifiers};

        push @purl, ('?', join('&', @qualifiers)) if (@qualifiers);

    }

    # Subpath
    if ($self->subpath) {

        my $subpath = $self->subpath;

        $subpath =~ s{\.\./}{};
        $subpath =~ s{\./}{};

        my @subpath = map { _encode($_) } split '/', $subpath;
        push @purl, ('#', join('/', @subpath));

    }

    return join '', @purl;

}

sub to_hash {

    my $self = shift;

    my %hash = map { $_ => $self->{components}->{$_} } qw[scheme type name version namespace qualifiers subpath];
    return \%hash;

}

sub TO_JSON { shift->to_hash }

sub _component {

    my ($self, $component, $value) = @_;

    if (@_ == 3) {
        $self->{components}->{$component} = $value;
    }

    return $self->{components}->{$component};

}

sub _url_encode {

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

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

}

sub _encode {

    my $string = shift;

    $string = _url_encode($string);

    $string =~ s{%3A}{:}g;
    $string =~ s{/}{%2F}g;

    return $string;

}

sub _url_decode {

    my $string = shift;
    return unless $string;

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

}

1;

__END__