File Coverage

blib/lib/SeeAlso/Identifier/Factory.pm

Criterion	Covered	Total	%
statement	77	82	93.9
branch	24	38	63.1
condition	1	3	33.3
subroutine	14	16	87.5
pod	3	3	100.0
total	119	142	83.8

use strict;
use warnings;
package SeeAlso::Identifier::Factory;
{
  $SeeAlso::Identifier::Factory::VERSION = '0.71';
}
#ABSTRACT: Identify and create identifiers

use SeeAlso::Identifier;
use Carp;


sub new {
    my ($class, %params) = @_;

    my $self = bless {
        type => [ 'SeeAlso::Identifier' ]
    }, $class;

    my $type  = $params{'type'};
    my $parse = $params{'parse'};

    if ($parse) {
        croak('parse parameter must be a code reference')
            unless ref($parse) eq 'CODE';
        $self->{parse} = $parse;
    }

    if (ref($type) eq 'ARRAY') {
        $self->{type} = $type;
    } elsif (not ref($type) and $type) {
        $self->{type} = [$type];
    } else {
        croak('type parameter must be scalar or array reference');
        # TODO: also support hash reference
    }

    ## no critic
    foreach my $type (@{$self->{type}}) {
        if ( not eval 'require ' . $type ) {
            if ( @{$self->{type}} == 1 ) {
                $params{type} = $type;
                makeclass( %params );
            }
        }
        UNIVERSAL::isa( $type, 'SeeAlso::Identifier' )
            or croak("$type must be a (subclass of) SeeAlso::Identifier");
    }
    ## use critic

    return $self;
}


sub create {
    my ($self, $value) = @_;

    # optional pre-parsing
    $value = $self->{parse}->($value) if $self->{parse};

    # use the first type that successfully parses the value
    foreach my $type (@{$self->{type}}) {
        my $id = $type->new( $value );
        return $id if $id;
    }

    # if none of the types creates a non-empty identifier, use the first type
    return $self->{type}->[0]->new( $value );
}


sub makeclass {
    my (%params) = @_;

    my $type      = $params{'type'}; # required
    my $parse     = $params{'parse'};
    my $canonical = $params{'canonical'};
    my $hash      = $params{'hash'};
    my $cmp       = $params{'cmp'};

    my @out = "{\n  package $type;";
    push @out, '  require SeeAlso::Identifier; use Data::Dumper;';
    push @out, '  our @ISA = qw(SeeAlso::Identifier);';
    if ($parse) {
        push @out, '  sub parse {';
        push @out, '    my $value = $parse->( shift );';
        push @out, '    return defined $value ? "$value" : "";';
        push @out, '  }';
    }

    push @out, 'sub canonical { my $s = $canonical->($_[0]->value); defined $s ? "$s" : ""; }'
        if $canonical;

    push @out, 'sub hash { my $s = $hash->($_[0]->value); defined $s ? "$s" : ""; }'
        if $hash;

    # TODO: cmp

    push @out, '1; };';
    my $out = join("\n",@out);

    ## no critic
    # print $out;# if $print;
    { no warnings; eval $out; }
    carp $@ if $@;
    ## use critic

    return $type;
}

1;

__END__