view release on metacpan or  search on metacpan

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

# Copyright (c) 2025 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: Extractor for identifiers from URIs

package Data::URIID::Barcode;

use v5.16;
use strict;
use warnings;

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

our $VERSION = v0.20;

use parent 'Data::URIID::Base';

use constant {map {$_ => []} qw(TYPE_UNKNOWN TYPE_OTHER TYPE_QRCODE TYPE_EAN13 TYPE_EAN8)};

my %_type_info = (
    TYPE_UNKNOWN()  => {
        type    => TYPE_UNKNOWN,
        special => 1,
    },
    TYPE_OTHER()    => {
        type    => TYPE_OTHER,
        special => 1,
    },
    TYPE_QRCODE()   => {
        type    => TYPE_QRCODE,
        aliases => [qw(qrcode qr-code)],
    },
    TYPE_EAN13()    => {
        type    => TYPE_EAN13,
        aliases => [qw(ean13 ean-13)],
    },
    TYPE_EAN8()     => {
        type    => TYPE_EAN8,
        aliases => [qw(ean8 ean-8)],
    },
);



sub sheet {
    my ($pkg, %opts) = @_;
    my $from        = delete $opts{from};
    my $filename    = delete $opts{filename};
    my $template    = delete $opts{template};
    my $values      = delete $opts{values};
    my $filter_type = delete $opts{filter_type};
    my $filter_data = delete $opts{filter_data};
    my %pass_opts;
    my @res;
    my $done;

    foreach my $key (qw(extractor type)) {
        $pass_opts{$key} = delete $opts{$key} // next;;
    }

    if (!defined($from) && defined($values)) {
        @res = map {{barcode => $_, quality => 0.001}}
               map {$pkg->new(%pass_opts, ref($_) ? (from => $_) : (data => sprintf($template // '%s', $_)))}
               @{$values};
               $done = 1;
    } elsif (!defined($from) && defined($filename)) {
        require Image::Magick;
        $from = Image::Magick->new();
        $from->Read($filename) && croak 'Cannot read file';
    }

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

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

        } else {
            @res = grep {$_->{barcode}->{data} =~ $filter_data} @res;
        }
    }

    if (wantarray) {
        return map {$_->{barcode}} @res;
    } else {
        my $max_length;

        croak 'No code found' unless scalar @res;

        foreach my $res (@res) {
            my $barcode = $res->{barcode};
            my $length = length($barcode->data);
            $max_length = $length if !defined($max_length) || $max_length < $length;
        }

        foreach my $res (@res) {
            my $barcode = $res->{barcode};
            $res->{quality} *= $barcode->_quality_by_type * (length($barcode->data) / $max_length);
        }

        return (sort {$b->{quality} <=> $a->{quality}} @res)[0]{barcode};
    }
}


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

    if (defined(my $from = delete($opts{from}))) {
        $self = eval {$pkg->sheet(from => $from)};
        return $self if defined $self;

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

        if (eval {$from->isa('Data::URIID::Result')}) {
            $opts{data} //= $from->url->as_string;
            $opts{type} //= TYPE_QRCODE;
        } elsif (eval {$from->isa('Data::URIID::Base')}) {
            $opts{data} //= $from->ise;
            $opts{type} //= TYPE_QRCODE;
        } elsif (eval {$from->isa('Data::Identifier')}) {
            $opts{data} //= $from->ise;
            $opts{type} //= TYPE_QRCODE;
        } elsif (eval {$from->isa('URI')}) {
            $opts{data} //= $from->as_string;
            $opts{type} //= TYPE_QRCODE;
        } else {
            croak 'Unsupported/invalid from type';
        }
    }

    croak 'No type given' unless defined $opts{type};
    croak 'No data given' unless defined $opts{data};

    weaken($opts{extractor});

    $self = bless \%opts, $pkg;

    return $self;
}


sub data {
    my ($self, %opts) = @_;
    delete $opts{default};
    delete $opts{no_defaults};

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

    return $self->{data};
}


sub type {
    my ($self, %opts) = @_;
    delete $opts{default};
    delete $opts{no_defaults};

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

    return $self->{type};
}


sub has_type {
    my ($self, $type, %opts) = @_;
    delete $opts{default};
    delete $opts{no_defaults};

    croak 'Stray options passed' if scalar keys %opts;
    croak 'No type passed' unless defined $type;

    if (ref($type) && !exists $_type_info{$type}) {
        foreach my $t (@{$type}) {
            return 1 if $self->{type} == $t;
        }
    }

    return $self->{type} == $type;
}


sub render {
    my ($self, %opts) = @_;
    my $filename = delete $opts{filename};
    my $success;

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

    eval {
        if ($self->has_type(TYPE_QRCODE)) {
            require Imager::QRCode;

            my $qrcode = Imager::QRCode->new(level => 'H');
            my $img = $qrcode->plot($self->data);