File Coverage

blib/lib/Type/TinyX/Facets.pm

Criterion	Covered	Total	%
statement	59	59	100.0
branch	6	10	60.0
condition	5	8	62.5
subroutine	14	14	100.0
pod	2	2	100.0
total	86	93	92.4

package Type::TinyX::Facets;

# ABSTRACT: Easily create a facet parameterized Type::Tiny type

use strict;
use warnings;

our $VERSION = '0.03';

use B qw(perlstring);
use base 'Exporter::Tiny';
use Exporter::Tiny qw(mkopt);
use Carp;
use Safe::Isa;

our @EXPORT = qw'facet facetize';

my %FACET;




























sub facet {

    my ( $name, $coderef ) = @_;

    my $caller = caller;

    $FACET{$caller} ||= {};
    $FACET{$caller}{$name} = $coderef;
}




























sub facetize {

    # type may be first or last parameter
    my $self
      = $_[-1]->$_isa( 'Type::Tiny' )
      ? pop
      : croak( "type object must be last parameter\n" );

    my $FACET = $FACET{ caller() };

    my @facets = map {
        my ( $facet, $sub ) = @{$_};
        $sub ||= $FACET->{$facet} || croak( "unknown facet: $facet" );
        [ $facet, $sub ];
    } @{ mkopt( \@_ ) };


    my $name = "$self";

    my $inline_generator = sub {
        my %p_not_destroyed = @_;
        return sub {
            my %p   = %p_not_destroyed;    # copy;
            my $var = $_[1];
            my $r   = sprintf(
                '(%s)',
                join( ' and ',
                    $self->inline_check( $var ),
                    map { $_->[1]->( \%p, $var, $_->[0] ) } @facets ),
            );

            croak sprintf(
                'Attempt to parameterize type "%s" with unrecognised parameter%s %s',
                $name,
                scalar( keys %p ) == 1 ? '' : 's',
                join( ", ", map( qq["$_"], sort keys %p ) ),
            ) if keys %p;
            return $r;
        };
    };

    $self->{inline_generator}     = $inline_generator;
    $self->{constraint_generator} = sub {
        my $sub = sprintf( 'sub { %s }',
            $inline_generator->( @_ )->( $self, '$_[0]' ),
        );
        ## no critic( ProhibitStringyEval )
        eval( $sub ) or croak "could not build sub: $@\n\nCODE: $sub\n";
    };
    $self->{name_generator} = sub {
        my ( $s, %a ) = @_;
        sprintf( '%s[%s]',
            $s, join q[,],
            map sprintf( "%s=>%s", $_, perlstring $a{$_} ),
            sort keys %a );
    };

    return if $self->is_anon;

    ## no critic( ProhibitNoStrict )
    no strict qw( refs );
    no warnings qw( redefine prototype );
    *{ $self->library . '::' . $self->name } = $self->library->_mksub( $self );
}



1;

#
# This file is part of Type-TinyX-Facets
#
# This software is copyright (c) 2017 by Smithsonian Astrophysical Observatory.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#

__END__