view release on metacpan or  search on metacpan

lib/Data/URIID/Colour.pm  view on Meta::CPAN

# Copyright (c) 2023-2024 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: Extractor for identifiers from URIs

package Data::URIID::Colour;

use strict;
use warnings;

use overload '""' => \&rgb;

use Carp;
use Scalar::Util qw(weaken blessed);

our $VERSION = v0.20;

use parent qw(Data::URIID::Base Data::Identifier::Interface::Known);

my %_registered;



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

    if (defined(my $from = delete($opts{from}))) {
        if (blessed $from) {
            if ($from->isa('Data::URIID::Base')) {
                $opts{extractor} //= $from->extractor(default => undef);
            }

            if ($from->isa(__PACKAGE__)) {
                $opts{rgb} //= $from->rgb;
            } elsif ($from->isa('Data::Identifier')) {
                if (!defined($opts{rgb}) && eval {$from->generator->eq('55febcc4-6655-4397-ae3d-2353b5856b34')}) {
                    if (defined(my $v = $from->request)) {
                        if ($v =~ /^#[0-9a-fA-F]{6}$/) {
                            $opts{rgb} //= $v;
                        }
                    }
                }
                $from = $from->ise;
            } else {
                $from = $from->ise;
            }
        }

        $opts{rgb} //= $_registered{$from};
    }

    croak 'No RGB value given' unless defined $opts{rgb};

    $opts{rgb} = uc($opts{rgb});
    $opts{rgb} =~ /^#[0-9A-F]{6}$/ or die 'Bad format';

    weaken($opts{extractor});

    $self = bless \%opts, $pkg;

    if (delete $opts{register}) { # not (yet) part of public API
        $_registered{$self->ise} //= $opts{rgb};
        Data::Identifier::Generate->colour($opts{rgb})->register;
    }

    return $self;
}


sub rgb {
    my ($self) = @_;
    return $self->{rgb} // croak 'No RGB value';
}


sub known {
    my ($pkg, $class, %opts) = @_;
    $opts{extractor} //= $pkg->extractor(default => undef) if ref $pkg;
    return $pkg->SUPER::known($class, %opts);
}

# --- Overrides for Data::URIID::Base ---

sub ise {
    my ($self, %opts) = @_;

    unless (defined $self->{ise}) {
        require Data::Identifier::Generate;
        $self->{ise} = Data::Identifier::Generate->colour($self->rgb)->ise;
    }

    return $self->SUPER::ise(%opts);
}

sub displayname {
    my ($self, %opts) = @_;
    return $self->SUPER::displayname(%opts, _fallback => $self->rgb);
}

# --- Overrides for Data::URIID::Base ---
sub _known_provider {
    my ($pkg, $class, %opts) = @_;
    croak 'Unsupported options passed' if scalar(keys %opts);
    return ([keys %_registered], rawtype => 'ise') if $class eq ':all';
    croak 'Unsupported class';
}

# ---- Private helpers ----

# Private for now.
sub displaycolour {
    my ($self) = @_;
    return $self;
}

1;