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.24';
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__

=encoding utf-8

=head1 NAME

URI::PackageURL - Perl extension for PURL (Package URL)

=head1 SYNOPSIS

  use URI::PackageURL;

  # OO-interface
  
  # Encode components in PURL string
  $purl = URI::PackageURL->new(
    type      => 'cpan',
    namespace => 'GDT',
    name      => 'URI-PackageURL',
    version   => '2.24'
  );
  
  say $purl; # pkg:cpan/GDT/URI-PackageURL@2.24

  # Parse a PURL string
  $purl = URI::PackageURL->from_string('pkg:cpan/GDT/URI-PackageURL@2.24');
  
  
  # use setter methods
  
  my $purl = URI::PackageURL->new(type => 'cpan', namespace => 'GDT', name => 'URI-PackageURL');

  say $purl; # pkg:cpan/GDT/URI-PackageURL
  say $purl->version; # undef

  $purl->version('2.24');
  say $purl; # pkg:cpan/GDT/URI-PackageURL@2.24
  say $purl->version; # 2.24
  
  
  # exported functions

  $purl = decode_purl('pkg:cpan/GDT/URI-PackageURL@2.24');
  say $purl->type;  # cpan

  $purl_string = encode_purl(type => cpan, namespace => 'GDT', name => 'URI-PackageURL', version => '2.24');
  say $purl_string; # pkg:cpan/GDT/URI-PackageURL@2.24
  
  
  # uses the legacy CPAN PURL type, to be used only for compatibility (will be removed in the future)
  
  $ENV{PURL_LEGACY_CPAN_TYPE} = 1;
  URI::PackageURL->new(type => 'cpan', name => 'URI::PackageURL');


  # alias

  $purl = PURL->new(
    type      => 'cpan',
    namespace => 'GDT',
    name      => 'URI-PackageURL',
    version   => '2.24'
  );

  $purl = PURL->from_string('pkg:cpan/GDT/URI-PackageURL');


  # clone

  $cloned = $purl->clone;

  $cloned->version('1.00');

  say $cloned; # pkg:cpan/GDT/URI-PackageURL@1.00
  say $purl;   # pkg:cpan/GDT/URI-PackageURL@2.24
  

=head1 DESCRIPTION

This module converts PURL components to PURL string and vice versa.

A PURL (Package URL) is a URL string used to identify and locate a software
package in a mostly universal and uniform way across programing languages,
package managers, packaging conventions, tools, APIs and databases.

L<https://github.com/package-url/purl-spec>

L<TC54 - Software and system transparency|https://tc54.org/>

L<ECMA-427 - Package-URL (PURL) specification|https://ecma-international.org/publications-and-standards/standards/ecma-427/>

A purl is a URL composed of seven components:

    scheme:type/namespace/name@version?qualifiers#subpath

Components are separated by a specific character for unambiguous parsing.

The definition for each components is:

=over 2

=item * "scheme": this is the URL scheme with the constant value of "pkg".
One of the primary reason for this single scheme is to facilitate the future
official registration of the "pkg" scheme for package URLs. Required.

=item * "type": the package "type" or package "protocol" such as cpan, maven, npm,
nuget, gem, pypi, etc. Required.

=item * "namespace": some name prefix such as a Maven groupid, a Docker image
owner, a GitHub user or organization. Optional and type-specific.

=item * "name": the name of the package. Required.

=item * "version": the version of the package. Optional.

=item * "qualifiers": extra qualifying data for a package such as an OS,
architecture, a distro, etc. Optional and type-specific.

=item * "subpath": extra subpath within a package, relative to the package root.
Optional.

=back

=head2 CPAN PURL TYPE

C<cpan> is an official PURL type (L<https://github.com/package-url/purl-spec/blob/main/types-doc/cpan-definition.md>)

=over 2

=item * The default repository is C<https://www.cpan.org/>.

=item * The C<namespace> is the CPAN id of the author/publisher. It MUST be written uppercase and is required.

=item * The C<name> is the distribution name and is case sensitive. A distribution name MUST NOT contain the string C<::>.

=item * The C<version> is the distribution version.

=item * Optional qualifiers may include:

=over

=item * C<repository_url>: CPAN/MetaCPAN/BackPAN/DarkPAN repository base URL (default is https://www.cpan.org)

=item * C<download_url>: URL of package or distribution

=item * C<vcs_url>: extra URL for a package version control system

=item * C<ext>: file extension (default is tar.gz)

=back

=back

=head3 Examples

    pkg:cpan/DROLSKY/DateTime@1.55
    pkg:cpan/GDT/URI-PackageURL
    pkg:cpan/OALDERS/libwww-perl@6.76

=head3 Legacy CPAN PURL type

Add C<PURL_LEGACY_CPAN_TYPE> environment variable for use the legacy CPAN PURL type.

B<NOTE>: This is only to be used for compatibility purposes (it will be removed in the future).

=head2 FUNCTIONAL INTERFACE

They are exported by default:

=head3 B<encode_purl>

    $purl_string = encode_purl(%purl_components)

Converts the given PURL components to PURL string. Croaks on error.

This function call is functionally identical to:

    $purl_string = URI::PackageURL->new(%purl_components)->to_string;

=head3 B<decode_purl>

    $purl_components = decode_purl($purl_string)

Converts the given PURL string to PURL components. Croaks on error.

This function call is functionally identical to:

    $purl = URI::PackageURL->from_string($purl_string);

=head2 OBJECT-ORIENTED INTERFACE

=head3 B<new>

    $purl = URI::PackageURL->new(%components)
    $purl = PURL->new(%components)

Create new L<URI::PackageURL> instance using provided PURL components
(type, name, version, etc).

Disable PURL-type validation:

    $purl = URI::PackageURL->new(validate => 0, ...);

Allowed parameters:

=over

=item * C<validate>, Enable/Disable PURL-type validation (default: C<1>).

=item * C<type>, PURL "type" component.

=item * C<namespace>, PURL "namespace" component.

=item * C<name>, PURL "name" component.

=item * C<version>, PURL "version" component.

=item * C<qualifiers>, PURL "qualifiers" component (default: C<{}>).

=item * C<subpath>, PURL "subpath" component.

=back

=head3 B<scheme>

The scheme is a constant with the value "pkg".

=head3 B<type>

The package "type" or package "protocol" such as cpan, maven, npm, nuget, gem, pypi, etc.

=head3 B<namespace>

Some name prefix such as a Maven groupid, a Docker image owner, a GitHub user or
organization. Optional and type-specific.

=head3 B<name>

The "name" of the package.

=head3 B<version>

The "version" of the package.

=head3 B<qualifiers>

Extra qualifying data for a package such as an OS, architecture, a distro, etc.

=head3 B<subpath>

Extra subpath within a package, relative to the package root.

=head3 B<to_string>

Stringify Package URL components.

=head3 B<to_urls>

Return B<download> and/or B<repository> URLs.

=head3 B<download_url>

Return B<download> URL.

See C<purl_to_urls> in L<URI::PackageURL::Util>.

=head3 B<repository_url>

Return B<repository> URL.

See C<purl_to_urls> in L<URI::PackageURL::Util>.

=head3 B<to_hash>

Turn PURL components into a hash reference.

=head3 B<definition>

Return L<URI::PackageURL::Type> instance.

=head3 B<clone>

Clone PURL object.

    $cloned = $purl->clone;

    $cloned->version('1.00');

    say $cloned; # pkg:cpan/GDT/URI-PackageURL@1.00
    say $purl;   # pkg:cpan/GDT/URI-PackageURL@2.24

=head3 B<TO_JSON>

Helper method for JSON modules (L<JSON>, L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS>, L<Mojo::JSON>, etc).

    use Mojo::JSON qw(encode_json);

    say encode_json($purl);

    # {
    #    "name" : "URI-PackageURL",
    #    "namespace" : "GDT",
    #    "qualifiers" : {},
    #    "scheme" : "pkg",
    #    "subpath" : null,
    #    "type" : "cpan",
    #    "version" : "2.24"
    # }

=head3 B<from_string>

    $purl = URI::PackageURL->from_string($purl_string);
    $purl = PURL->from_string($purl_string);

Converts the given PURL string to PURL components and return L<URI::PackageURL>
instance. Croaks on error.


=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/giterlizzi/perl-URI-PackageURL/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/giterlizzi/perl-URI-PackageURL>

    git clone https://github.com/giterlizzi/perl-URI-PackageURL.git


=head1 AUTHOR

=over

=item * Giuseppe Di Terlizzi <gdt@cpan.org>

=back


=head1 LICENSE AND COPYRIGHT

This software is copyright (c) 2022-2026 by Giuseppe Di Terlizzi.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut