File Coverage

lib/Data/Identifier/Util.pm

Criterion	Covered	Total	%
statement	111	234	47.4
branch	74	166	44.5
condition	10	63	15.8
subroutine	14	17	82.3
pod	5	7	71.4
total	214	487	43.9

# Copyright (c) 2023-2026 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: format independent identifier object


package Data::Identifier::Util;

use v5.14;
use strict;
use warnings;

use parent qw(Data::Identifier::Interface::Userdata Data::Identifier::Interface::Subobjects);

use Carp;

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

our $VERSION = v0.29;

my $_DEFAULT_INSTANCE = __PACKAGE__->new;

my %_4plus12_prefix = (
    sni => (0<<15)|(0<<14),
    sid => (0<<15)|(1<<14),
    hdi => (1<<15)|(0<<14),
    udi => (1<<15)|(1<<14),
);

my $_logical = '5e80c7b7-215e-4154-b310-a5387045c336';

my %_raes_to_raen = (
    NONE    =>  0,
    NOENT   =>  2,
    NOSYS   =>  6,
    NOTSUP  =>  7,
    NOMEM   => 12,
    INVAL   => 13,
    FAULT   => 18,
    IO      => 19,
    NODATA  => 25,
    NOSPC   => 38,
    TYPEMM  => 39,
    RO      => 45,
    ILLSEQ  => 56,
    BADEXEC => 79,
    BADFH   => 83,
);
my %_logicals_to_sni = (
    sni     =>  10,
    sid     => 115,
    raen    => 116,
    chat0w  => 118,
    uuid    => 119,
    uri     => 121,
    asciicp => 122,
    oid     => 120,
    wd      => 123,
    logical => 129,
    false   => 189,
    true    => 190,
);
my %_logicals_to_sid = (
    asi         => 1,
    tagname     => 3,
    SEEK_SET    => 34,
    SEEK_CUR    => 35,
    SEEK_END    => 36,
    backwards   => 43,
    forwards    => 44,
    black       => 61,
    white       => 62,
    grey        => 63,
    red         => 119,
    green       => 120,
    blue        => 121,
    cyan        => 122,
    magenta     => 123,
    yellow      => 124,
    orange      => 125,
    gtin        => 160,
    left        => 192,
    right       => 193,
    up          => 194,
    down        => 195,
    north       => 208,
    east        => 209,
    south       => 210,
    west        => 211,
);

my %_wk = (
    bunit_ns    => {uuid => 'e8e9846a-37ec-42fd-8e89-d15f5467aa9c', displayname => 'unit-namespace'},
    bunit_gen   => {uuid => 'b1620795-b29a-4aea-ba46-371b187d0a4b', displayname => 'unit-generator'},
    dunit_ns    => {uuid => 'da8a7fe4-935c-4bf7-9bd1-aaf8fc39305b', displayname => 'derived-unit-namespace'},
    dunit_gen   => {uuid => 'c3446cff-672b-4247-b62c-755a295ee15f', displayname => 'derived-unit-generator'},
    #x => {uuid => '', displayname => ''},
);

foreach my $value (values %_wk) {
    my $uuid = delete $value->{uuid};
    $value = Data::Identifier->new(uuid => $uuid, %{$value})->register;
}

my %_base_units = (
    map {
        $_->{id} = Data::Identifier::Generate->generic(
            namespace => $_wk{bunit_ns},
            generator => $_wk{bunit_gen},
            style => 'name-based',
            request => $_->{symbol},
            displayname => $_->{name},
        )->register;
        $_->{symbol} => $_
    } (
        {name => 'second',      symbol => 's',      dimension => 'T',           quantity => 'time',                         variable => [qw(t)]},
        {name => 'metre',       symbol => 'm',      dimension => 'L',           quantity => 'length',                       variable => [qw(l x r)]},
        {name => 'kilogram',    symbol => 'kg',     dimension => 'M',           quantity => 'mass',                         variable => [qw(m)]},
        {name => 'ampere',      symbol => 'A',      dimension => 'I',           quantity => 'electric current',             variable => [qw(I i)]},
        {name => 'kelvin',      symbol => 'K',      dimension => "\N{U+0398}",  quantity => 'thermodynamic temperature',    variable => [qw(T)]},
        {name => 'mole',        symbol => 'mol',    dimension => 'N',           quantity => 'amount of substance',          variable => [qw(n)]},
        {name => 'candela',     symbol => 'cd',     dimension => 'J',           quantity => 'luminous intensity',           variable => [qw(Iv)]},
    )
);

my %_number_units = map { $_ => Data::Identifier::Generate->integer($_)->register } (2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73); # primes

my %_composite_unit_elements = (
    Hz      => {s => -1},
    N       => {s => -2, m =>  1, kg =>  1},
    Pa      => {s => -2, m => -1, kg =>  1},
    J       => {s => -2, m =>  2, kg =>  1},
    W       => {s => -3, m =>  2, kg =>  1},
    C       => {s =>  1,                    A =>  1},
    V       => {s => -3, m =>  2, kg =>  1, A => -1},
    F       => {s =>  4, m => -2, kg => -1, A =>  2},
    "\N{U+03A9}"    => {s => -3, m =>  2, kg =>  1, A => -2},
    "\N{U+2126}"    => {s => -3, m =>  2, kg =>  1, A => -2}, # alias
    ohm             => {s => -3, m =>  2, kg =>  1, A => -2}, # alias
    S       => {s =>  3, m => -2, kg => -1, A =>  2},
    Wb      => {s => -2, m =>  2, kg =>  1, A => -1},
    T       => {s => -2,          kg =>  1, A => -1},
    H       => {s => -2, m =>  2, kg =>  1, A => -2},
    kat     => {s => -1,                             mol => 1},
    10      => {2 => 1,         5 => 1},
    12      => {2 => 2, 3 => 1},
    24      => {2 => 3, 3 => 1},
    28      => {2 => 2,                  7 => 1},
    30      => {2 => 1, 3 => 1, 5 => 1},
    60      => {2 => 2, 3 => 1, 5 => 1},
    365     => {                5 => 1, 73 => 1},
    366     => {2 => 1, 3 => 1,         61 => 1},
    3600    => {2 => 4, 3 => 2, 5 => 2},
    86400   => {2 => 7, 3 => 3, 5 => 2},
);

my %_component_to_name = (
    # Units:
    (map {$_base_units{$_}{id}->uuid => $_} keys %_base_units),
    # Numbers:
    (map {$_number_units{$_}->uuid => $_} keys %_number_units),
);

my %_si_prefix = (
    quetta  =>  30, Q   => 30,
    ronna   =>  27, R   => 27,
    yotta   =>  24, Y   => 24,
    zetta   =>  21, Z   => 21,
    exa     =>  18, E   => 18,
    peta    =>  15, P   => 15,
    tera    =>  12, T   => 12,
    giga    =>   9, G   => 9,
    mega    =>   6, M   => 6,
    kilo    =>   3, k   => 3,
    hecto   =>   2, h   => 2,
    deca    =>   1, da  => 1,
    deci    =>  -1, d   => -1,
    centi   =>  -2, c   => -2,
    milli   =>  -3, m   => -3,
    micro   =>  -6, "\N{GREEK SMALL LETTER MU}" => -6,
    nano    =>  -9, n   => -9,
    pico    => -12, p   => -12,
    femto   => -15, f   => -15,
    atto    => -18, a   => -18,
    zepto   => -21, z   => -21,
    yocto   => -24, y   => -24,
    ronto   => -27, r   => -27,
    quecto  => -30, q   => -30,
);


sub new {
    my ($pkg, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    return bless {}, $pkg;
}


sub pack {
    my ($self, $template, $identifier, @opts) = _normalise_args(@_);
    my $pack_template;
    my $v;

    croak 'Stray options passed' if scalar @opts;

    $template //= '';
    $identifier = Data::Identifier->new(from => $identifier) unless eval {$identifier->isa('Data::Identifier')};

    if ($template =~ /^(sid|sni|hdi|udi)([1-9][0-9]*)$/) {
        my $bits = int($2);

        $v = $identifier->as(Data::Identifier->new(wellknown => $1), no_defaults => 1);

        if ($bits == 8) {
            $pack_template = 'C';
        } elsif ($bits == 16) {
            $pack_template = 'n';
        } elsif ($bits == 32) {
            $pack_template = 'N';
        } else {
            croak 'Invalid width: '.$bits;
        }
    } elsif ($template eq '4+12') {
        my $prefix;

        foreach my $type (qw(sid sni hdi udi)) {
            $v = $identifier->as(Data::Identifier->new(wellknown => $type), no_defaults => 1, default => undef);
            if (defined $v) {
                if ($v < 0 || $v > 0x0FFF) {
                    next;
                }
                $v |= $_4plus12_prefix{$type};
                $pack_template = 'n';
                last;
            }
        }
    } elsif ($template eq 'uuid128') {
        return pack('H*', $identifier->uuid(no_defaults => 1) =~ tr/-//dr);
    } elsif ($template eq 'uuidhexdash') {
        return $identifier->uuid(no_defaults => 1);
    } elsif ($template eq 'uuidHEXDASH') {
        return $identifier->uuid(no_defaults => 1) =~ tr/a-f/A-F/r;
    } elsif ($template eq 'Data::Identifier') {
        return $identifier;
    }

    if (defined($v) && defined($pack_template)) {
        my ($min, $max);

        if ($pack_template eq 'C') {
            ($min, $max) = (0, 0xFF);
        } elsif ($pack_template eq 'n') {
            ($min, $max) = (0, 0xFFFF);
        } elsif ($pack_template eq 'N') {
            ($min, $max) = (0, 0xFFFF_FFFF);
        }

        if ((defined($min) && $v < $min) || (defined($max) && $v > $max)) {
            croak 'Identifier not in range for '.$template.': '.$v;
        }

        return pack($pack_template, $v);
    }

    croak 'Unknown template: '.$template;
}


sub unpack {
    my ($self, $template, $data, @opts) = _normalise_args(@_);
    my $pack_template;
    my $type;

    croak 'Stray options passed' if scalar @opts;

    if ($template =~ /^(sid|sni|hdi|udi)([1-9][0-9]*)$/) {
        my $bits = int($2);
        $type = $1;

        if ($bits == 8) {
            $pack_template = 'C';
        } elsif ($bits == 16) {
            $pack_template = 'n';
        } elsif ($bits == 32) {
            $pack_template = 'N';
        } else {
            croak 'Invalid width: '.$bits;
        }
    } elsif ($template eq '4+12') {
        my $v;
        my $prefix;

        croak 'Input has bad length, expected 2 bytes, got '.length($data) unless length($data) == 2;

        $v = unpack('n', $data);
        $prefix = $v & 0xF000;
        $v      = $v & 0x0FFF;

        foreach my $key (keys %_4plus12_prefix) {
            if ($prefix == $_4plus12_prefix{$key}) {
                return Data::Identifier->new($key => $v);
            }
        }

        croak sprintf('Invalid/unknown prefix: 0x%04x', $prefix);
    } elsif ($template eq 'uuid128') {
        croak 'Input has bad length, expected 16 bytes, got '.length($data) unless length($data) == 16;
        return Data::Identifier->new(uuid => join('-', unpack('H8H4H4H4H12', $data)));
    } elsif ($template eq 'uuidhexdash') {
        return Data::Identifier->new(uuid => $data);
    } elsif ($template eq 'uuidHEXDASH') {
        return Data::Identifier->new(uuid => $data);
    } elsif ($template eq 'Data::Identifier') {
        # We don't care too much here if it is actually a Data::Identifier or just any other supported type.
        # Data::Identifier will do the right thing anyway.
        return Data::Identifier->new(from => $data);
    }

    if (defined($type) && defined($pack_template)) {
        my $len = length($data);
        my $exp;

        if ($pack_template eq 'C') {
            $exp = 1;
        } elsif ($pack_template eq 'n') {
            $exp = 2;
        } elsif ($pack_template eq 'N') {
            $exp = 4;
        }

        croak 'Input has bad length, expected '.$exp.' bytes, got '.$len unless $len == $exp;

        return Data::Identifier->new($type => unpack($pack_template, $data));
    }

    croak 'Unknown template: '.$template;
}


sub parse_sirtx {
    my ($self, $data, @opts) = _normalise_args(@_);

    croak 'Stray options passed' if scalar @opts;

    $self->_load_well_known;

    $data =~ s/^\[(.+)\]$/$1/;

    # Experimental:
    if (my ($d, $v) = $data =~ /^(\[.+?\]):(.+)$/) {
        $d = $self->parse_sirtx($d);
        $v =~ s/^\[(.+)\]$/$1/;
        return Data::Identifier->new($d => $v);
    }

    if ($data =~ /^'([0-9]*)$/) {
        my $num = int($1 || '0');
        require Data::Identifier::Generate;
        return Data::Identifier::Generate->integer($num);
    } elsif ($data =~ /^\/([0-9]+)$/) {
        return Data::Identifier->new('d73b6550-5309-46ad-acc9-865c9261065b' => int($1));
    } elsif ($data =~ /^(sid|sni):([0-9]+)$/) {
        return Data::Identifier->new($1 => int($2));
    } elsif ($data =~ /^uuid:([0-9a-fA-F-]+)$/) {
        return Data::Identifier->new(uuid => $1);
    } elsif ($data =~ /^wd:([QPL][1-9][0-9]*)$/) {
        return Data::Identifier->new(wd => $1);
    } elsif ($data =~ /^~([0-9]+)$/) {
        return Data::Identifier->new(hdi => int($1));
    } elsif ($data =~ /^raen:([0-9]+)$/) {
        return Data::Identifier->new('2bffc55d-7380-454e-bd53-c5acd525d692' => int($1));
    } elsif ($data =~ /^chat0w:([0-9]+)$/) {
        return Data::Identifier->new('2c7e15ed-aa2f-4e2f-9a1d-64df0c85875a' => int($1));
    } elsif ($data =~ /^asciicp:([0-9]+)$/) {
        require Data::Identifier::Generate;
        return Data::Identifier::Generate->unicode_character(ascii => int($1));
    } elsif ($data =~ /^raes:(.+)/) {
        if (defined(my $raen = $_raes_to_raen{$1})) {
            return Data::Identifier->new('2bffc55d-7380-454e-bd53-c5acd525d692' => $raen);
        }
    } elsif (defined $_logicals_to_sni{$data}) {
        return Data::Identifier->new(sni => $_logicals_to_sni{$data});
    } elsif (defined $_logicals_to_sid{$data}) {
        return Data::Identifier->new(sid => $_logicals_to_sid{$data});
    } elsif ($data =~ /^logical:(.+)$/) {
        $data = $1;
        if (defined $_logicals_to_sni{$data}) {
            return Data::Identifier->new(sni => $_logicals_to_sni{$data});
        } elsif (defined $_logicals_to_sid{$data}) {
            return Data::Identifier->new(sid => $_logicals_to_sid{$data});
        }
    }

    croak 'Unsupported/invalid SIRTX identifier';
}


sub render_sirtx {
    my ($self, $identifier, @opts) = _normalise_args(@_);
    state $map = [
        [sid        => Data::Identifier->new(wellknown => 'sid')->register],
        [sni        => Data::Identifier->new(wellknown => 'sni')->register],
        [wd         => Data::Identifier->new(wellknown => 'wd')->register],
        ['/'        => Data::Identifier->new(uuid => 'd73b6550-5309-46ad-acc9-865c9261065b')->register],
        [raen       => Data::Identifier->new(uuid => '2bffc55d-7380-454e-bd53-c5acd525d692')->register],
        [chat0w     => Data::Identifier->new(uuid => '2c7e15ed-aa2f-4e2f-9a1d-64df0c85875a')->register],
        ['~'        => Data::Identifier->new(wellknown => 'hdi')->register],
    ];

    croak 'Stray options passed' if scalar @opts;

    $identifier = Data::Identifier->new(from => $identifier);

    if (defined(my Data::Identifier $generator = $identifier->generator(default => undef)) && defined(my $req = $identifier->request(default => undef))) {
        if ($generator->eq('53863a15-68d4-448d-bd69-a9b19289a191')) {
            return sprintf('\'%u', $req);
        } elsif ($generator->eq('d74f8c35-bcb8-465c-9a77-01010e8ed25c') && $req =~ /^[Uu]\+([0-9a-fA-F]{4,6})$/) {
            my $cp = hex $1;
            if ($cp < 0x80) {
                return sprintf('asciicp:%u', $cp);
            }
        }
    }

    foreach my $ent (@{$map}) {
        my $v = $identifier->as($ent->[1], no_defaults => 1, default => undef) // next;
        $v = sprintf($ent->[0] =~ /^[a-z]/ ? '%s:%s' : '%s%s', $ent->[0], $v);
        $v = '['.$v.']' if $v =~ /-/;
        return $v;
    }

    # Fallback:
    return sprintf('[uuid:%s]', $identifier->uuid);
}

# Too experimental for listing in public API.
# TODO: Get this on track for the public API!
sub parse_unit_request {
    my ($self, $template, $request, %opts) = _normalise_args(@_);
    my $exponentas = delete($opts{exponentas}) // 'int';
    my @res;

    croak 'Stray options passed' if scalar keys %opts;

    if ($template eq 'request') {
        foreach my $subreq (split(/--/, $request)) {
            my ($uuid, $neg, $exp_mul) = $subreq =~ /^([0-9a-f]{8}-(?:[0-9a-f]{4}-){3}[0-9a-f]{12})~(-?)([0-9])\z/;
            my $exp;

            #printf("%-42s -> <%s> <%1s> <%s>\n", $subreq, $uuid, $neg, $exp_mul);

            if ($exponentas eq 'int') {
                $exp = int($exp_mul);
                $exp = -$exp if $neg eq '-';
            } else {
                croak 'Invalid exponentas: '.$exponentas;
            }

            push(@res, {
                    component => Data::Identifier->new(uuid => $uuid),
                    exponent  => $exp,
                });
        }
    } else {
        croak 'Unknown template: '.$template;
    }

    return \@res;
}

# Too experimental for listing in public API.
# TODO: Get this on track for the public API!
sub render_unit_request {
    my ($pkg, $template, $request, %opts) = _normalise_args(@_);
    my $displayname = delete $opts{displayname};
    my $input;
    my %took;

    croak 'Stray options passed' if scalar keys %opts;

    if (ref($request) eq 'ARRAY') {
        $request = {map {($_component_to_name{$_->{component}->uuid} // croak 'Unknown base unit: '.$_->{component}->uuid) => $_->{exponent}} @{$request}};
    }

    if (defined(my $prefix = delete($request->{prefix}))) {
        $prefix = $_si_prefix{$prefix} // croak 'Bad prefix: '.$prefix;
        $request->{10} //= 0;
        $request->{10}  += $prefix;
    }

    foreach my $key (keys(%_composite_unit_elements)) {
        my $n = $_composite_unit_elements{$key};
        my $mul = delete($request->{$key}) // 0;
        croak 'Bad exponent: '.$mul if $mul != int($mul);
        $mul = int($mul);
        next if $mul == 0;
        foreach my $prime_element (keys %{$n}) {
            $request->{$prime_element} //= 0;
            $request->{$prime_element} += $n->{$prime_element} * $mul;
        }
    }

    foreach my $key (keys(%_base_units), keys(%_number_units)) {
        my $mul = delete($request->{$key}) // 0;
        croak 'Bad exponent: '.$mul if $mul != int($mul);
        $mul = int($mul);
        $took{$key} = $mul if $mul != 0;
    }

    {
        my @keys = keys %{$request};
        croak 'Bad extra units: '.join(', ', @keys) if scalar @keys;
    }

    unless (scalar(grep {!defined $_number_units{$_}} keys %took)) {
        my $i = 1;

        foreach my $key (keys %took) {
            $i *= $key ** $took{$key};
        }

        if ($i == int($i)) {
            return $pkg->pack($template => Data::Identifier::Generate->integer($i));
        }
        croak 'Invalid numeric only request';
    }

    # Rename from units to UUIDs as keys.
    foreach my $key (keys %took) {
        my $uuid = ($_number_units{$key} // $_base_units{$key}{id})->uuid;
        $took{$uuid} = delete $took{$key};
    }

    if (scalar(keys %took) == 1) {
        my ($mul) = values %took;
        if ($mul == 1) {
            my ($uuid) = keys %took;
            return $pkg->pack($template => Data::Identifier->new(uuid => $uuid));
        }
    }

    $input = join('--', map{$_.'~'.$took{$_}} sort keys %took);

    if ($template eq 'request') {
        return $input;
    }

    $opts{namespace} //= $_wk{dunit_ns},
    $opts{generator} //= $_wk{dunit_gen},
    $opts{input}       = $input;
    $opts{request}     = $input;
    $opts{displayname} = $displayname;

    return $pkg->pack($template => Data::Identifier::Generate->generic(%opts));
}

# ---- Private helpers ----

sub _normalise_args {
    my (@args) = @_;

    if (scalar(@args)) {
        if (ref($args[0]) && eval {$args[0]->isa(__PACKAGE__)}) {
            # no-op
        } elsif ($args[0] eq __PACKAGE__) {
            $args[0] = $_DEFAULT_INSTANCE;
        } else {
            unshift(@args, $_DEFAULT_INSTANCE);
        }

        return @args;
    }

    return ($_DEFAULT_INSTANCE);
}

sub _load_well_known {
    state $done = do {
        my %meta = (
            sni => \%_logicals_to_sni,
            sid => \%_logicals_to_sid,
        );

        foreach my $type (keys %meta) {
            my $hash = $meta{$type};

            foreach my $key (keys %{$hash}) {
                my $id = Data::Identifier->new($type => $hash->{$key});

                next unless defined $id->uuid(no_defaults => 1, default => undef);

                $id->{id_cache} //= {};
                $id->{id_cache}->{$_logical} //= $key;

                $id->register;
            }
        }
    };
}

1;

__END__