File Coverage

lib/Data/Identifier/Wellknown.pm

Criterion	Covered	Total	%
statement	41	153	26.8
branch	2	66	3.0
condition	2	45	4.4
subroutine	12	15	80.0
pod	2	2	100.0
total	59	281	21.0

# Copyright (c) 2023-2026 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: format independent identifier object


package Data::Identifier::Wellknown;

use v5.14;
use strict;
use warnings;
use utf8;

use Carp;
use Fcntl qw(SEEK_SET);

use Data::Identifier;
use Data::Identifier::Generate;

use parent 'Data::Identifier::Interface::Known';

our $VERSION = v0.29;

use constant {
    WK_UUID => '8be115d2-dc2f-4a98-91e1-a6e3075cbc31', # uuid
    WK_SID  => 'f87a38cb-fd13-4e15-866c-e49901adbec5', # small-identifier
    WK_SNI  => '039e0bb7-5dd3-40ee-a98c-596ff6cce405', # sirtx-numerical-identifier
};

my %imported;
my %loaded = (wellknown => undef, registered => undef); # consider two loaded to begin with.
my $start_of_data = DATA->tell;

foreach my $class (keys %loaded) {
    foreach my $id (Data::Identifier->known($class)) {
        _add_classes($id, $class);
    }
}

sub _known_provider {
    my ($pkg, $class, %opts) = @_;
    croak 'Unsupported options passed' if scalar(keys %opts);

    unless (exists $loaded{$class}) {
        __PACKAGE__->import($class);
    }

    if ($class eq 'wellknown' || $class eq 'registered' || $class eq ':all') {
        goto &Data::Identifier::_known_provider;
    } else {
        return ($imported{$class}, rawtype => 'Data::Identifier');
    }
}

sub import {
    my ($pkg, @args) = @_;
    my $id_type = Data::Identifier->new(wellknown => 'uuid');
    my $default_class;
    my %generator;
    my $namespace;
    my %found;
    my @extra_classes;

    return if exists $loaded{':all'}; # if we done :all we ... did all!

    @args = grep {!exists($loaded{$_})} @args;

    return unless scalar @args;

    DATA->seek($start_of_data, SEEK_SET);

    while (my $line = ) {
        my ($classes, $id, $displayname, $special);
        my @classes;
        my $found;

        $line =~ s/\s{2,}%.*$//;
        $line =~ s/^\s*%.*$//;
        $line =~ s/\s+$//;
        $line =~ s/^\s+//;
        $line =~ s/\r?\n$//;

        next if $line eq '';

        if ($line =~ /^\$/) {
            my ($command, $arg) = split(/\s+/, $line, 2);

            if ($command eq '$type') {
                if ($arg =~ /^(.+)=(.+)$/) {
                    $id_type = Data::Identifier->new($1, $2);
                } else {
                    $id_type = Data::Identifier->new(wellknown => $arg);
                }
                $namespace = undef;
            } elsif ($command eq '$class') {
                $default_class = $arg;
                @extra_classes = ();
            } elsif ($command eq '$extra_classes') {
                @extra_classes = split(/,/, $arg);
            } elsif ($command eq '$generator') {
                %generator = split(/[,=]/, $arg);
                $id_type = undef;
                $namespace = undef;
                foreach my $key (qw(generator namespace)) {
                    next unless defined $generator{$key};
                    $generator{$key} = Data::Identifier->new(from => $generator{$key})->register;
                }
            } elsif ($command eq '$namespace') {
                $namespace = $arg;
            } elsif ($command eq '$end') {
                last;
            } else {
                croak 'BUG';
            }
            next;
        }

        ($classes, $id, $displayname, $special) = split(/\s{2,}/, $line, 4);
        if ($classes eq '.') {
            @classes = ($default_class);
        } else {
            @classes = split(',', $classes);
        }
        if (defined($displayname)) {
            $displayname = undef if $displayname eq '.';
        }

        push(@classes, @extra_classes);

        foreach my $class_a (@classes) {
            foreach my $class_b (@args) {
                if ($class_a eq $class_b || $class_b eq ':all') {
                    $found = 1;
                    last;
                }
            }
        }
        next unless $found;

        {
            my $identifier;

            if (defined $id_type) {
                $identifier = Data::Identifier->new(
                    $id_type => $id,
                    defined($displayname) ? (displayname => $displayname) : (),
                );
            } else {
                $identifier = Data::Identifier::Generate->generic(
                    %generator,
                    request => $id,
                    defined($displayname) ? (displayname => $displayname) : (),
                );
            }

            if (defined $namespace) {
                my $uuid;

                if ($namespace =~ /^(.+),lc$/) {
                    $uuid = Data::Identifier::Generate->_uuid_v5($1, lc($id));
                } else {
                    $uuid = Data::Identifier::Generate->_uuid_v5($namespace, $id);
                }
                $identifier->{id_cache} //= {};
                $identifier->{id_cache}->{WK_UUID()} //= $uuid;
            }

            if (defined($special) && length($special)) {
                my %special = split(/[,=]/, $special);

                if (defined $special{sid}) {
                    $identifier->{id_cache} //= {};
                    $identifier->{id_cache}->{WK_SID()} //= $special{sid};
                }

                if (defined $special{sni}) {
                    $identifier->{id_cache} //= {};
                    $identifier->{id_cache}->{WK_SNI()} //= $special{sni};
                }
            }

            $identifier->{displayname} //= $displayname; # force-update, using internal API. DO NOT TRY AT HOME!
            $identifier->register;

            foreach my $class (@classes) {
                $found{$class} = undef;
                $imported{$class} //= [];
                push(@{$imported{$class}}, $identifier);
            }

            _add_classes($identifier, @classes);
        }
    }

    # deduplicate:
    foreach my $class (keys %found) {
        my %tmp = map {$_ => $_} @{$imported{$class}};
        @{$imported{$class}} = values %tmp;
    }

    # Mark classes loaded that we found data for.
    foreach my $class (@args) {
        if (exists($found{$class}) || $class eq ':all') {
            $loaded{$class} = undef;
        } else {
            croak 'Unsupported class: '.$class;
        }
    }
}


sub classes_of {
    my ($pkg, $identifier) = @_;
    $identifier = Data::Identifier->new(from => $identifier);

    return keys %{$identifier->userdata(__PACKAGE__, 'classes') // {}};
}


sub announce {
    my ($pkg, $type, $regs, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    $type = Data::Identifier->new(from => $type); # Force to Data::Identifier
    $type->register;                              # Ensure it is registered

    if (ref($regs) eq 'HASH') {
        $type = $type->uuid;                      # Convert to UUID for cache usage
        foreach my $key (keys %{$regs}) {
            my $identifier = Data::Identifier->new(from => $regs->{$key});
            $identifier->{id_cache} //= {};
            $identifier->{id_cache}->{$type} //= $key;
            $identifier->register;
        }
    } elsif (ref($regs) eq 'ARRAY') {
        foreach my $key (@{$regs}) {
            if (ref $key) {
                Data::Identifier->new(from => $key)->register;
            } else {
                Data::Identifier->new($type => $key)->register;
            }
        }
    } else {
        croak 'Unsupported data type';
    }
}

# ---- Private helpers ----

sub _add_classes {
    my ($identifier, @classes) = @_;
    my $set = $identifier->userdata(__PACKAGE__, 'classes') // $identifier->userdata(__PACKAGE__, 'classes' => {});
    $set->{$_} = undef foreach @classes, ':all', 'registered';
}

1;

=pod

=encoding UTF-8

=head1 NAME

Data::Identifier::Wellknown - format independent identifier object

=head1 VERSION

version v0.29

=head1 SYNOPSIS

    use Data::Identifier::Wellknown qw(classes...);
    e.g.:
    use Data::Identifier::Wellknown ':all';

(experimental since v0.07)

This package provides a simple list of well known identifiers.
Classes are loaded on demand. However for speedy lookup classes can
be imported (given via C arguments).

If a class is already loaded, it is not reloaded.
If a program knows the classes it will use early it makes sense to
include this module in the main program (or root module) before other modules that make
use of this module are used with all the used classes listed.
This improves speed as it will reduce the read of the full list to a single pass.
In contrast if every use will only list a single class that is not yet loaded loading will be most in-efficient.

B
This is an B package.
It's methods and classes are not stable.
But the package itself and the class C<:all> is.

This package implements L.

=head1 METHODS

=head2 classes_of

    my @classes = Data::Identifier::Wellknown->classes_of($identifier);

(experimental since v0.07)

Returns the classes the identifier is known for.
C<$identifier> is parsed as per C of L.

B
This module does not guarantee any specific order of the returned list.

B
Classes may not be included in returned list unless they (or C<:all>) have been
imported before.

B
This is an B method. It may be changed, renamed, or removed without notice.

=head2 announce

    Data::Identifier::Wellknown->announce($type => $data);

(experimental since v0.26)

This method can be used to announce additional well known identifiers.
It is mostly used by other modules to register identifiers for a given type related to those modules
and alias them to UUIDs.
This is mostly useful if those identifiers are mapped to UUIDs via a register (in contrast to a generator).

The type is passed as C<$type> which is parsed as per C of L.
It must resolve to an identifier with a defined UUID.
This module might make restrictions on the type identifiers can be registered for.

If C<$data> is a hashref the keys are understood as the identifiers of the type given via C<$type>
and the values are the corresponding identifiers (parsed as per C of L) to map to.

If C<$data> is an arrayref the values are understood as the identifiers.
L objects are created as needed and registered.

C<$type> and all identifiers updated by this method will be registered as per L.

=head1 AUTHOR

Philipp Schafft

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2023-2026 by Philipp Schafft .

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut

__DATA__