File Coverage

blib/lib/Type/TinyX/Facets.pm

Criterion	Covered	Total	%
statement	72	72	100.0
branch	7	12	58.3
condition	5	8	62.5
subroutine	18	18	100.0
pod	3	3	100.0
total	105	113	92.9

package Type::TinyX::Facets;

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

use strict;
use warnings;

our $VERSION = '1.2';

use B              ();
use Exporter::Tiny ();
use Eval::TypeTiny ();
use Safe::Isa;

use parent 'Exporter::Tiny';
our @EXPORT = qw( with_facets facet facetize );

# handle both generations of Type::Tiny interfaces to create library
# subs. only used by facetize.
my $type_to_coderef
  = exists &Eval::TypeTiny::type_to_coderef
  ? \&Eval::TypeTiny::type_to_coderef
  : do {
    require Type::Library;
    exists &Type::Library::_mksub;
  }
  ? sub { $_[0]->library->_mksub( $_[0] ) }
  : _croak( "can't find type-to-coderef function?" );

sub _croak {
    require Carp;
    goto &Carp::croak;
}

my %FACET;




























sub facet {

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

    my $caller = caller();

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






















sub with_facets {
    _with_facets( scalar caller(), @_ );
}


sub _with_facets {

    my ( $caller, $facets ) = ( shift, shift );

    my $FACET = $FACET{$caller};

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


    # so blithely stolen from Type::XSD::Lite.  Thanks TOBYINK!
    my %return;
    my $IG = $return{inline_generator} = sub {
        my %p_not_destroyed = @_;
        return sub {
            my %p   = %p_not_destroyed;    # copy;
            my $var = $_[1];
            my @r   = map $_->[1]->( \%p, $var, $_->[0] ), @facets;
            _croak sprintf(
                'Attempt to parameterize type "%s" with unrecognised parameter%s %s',
                $_[0]->name,
                scalar( keys %p ) == 1 ? '' : 's',
                Type::Utils::english_list( map( qq["$_"], sort keys %p ) ),
            ) if keys %p;
            return ( undef, @r );
        };
    };

    $return{constraint_generator} = sub {
        my $base   = do { no warnings 'once'; $Type::Tiny::parameterize_type };
        my %params = @_ or return $base;
        my @checks = $IG->( %params )->( $base, '$_[0]' );
        $checks[0] = $base->inline_check( '$_[0]' );
        my $sub = sprintf( 'sub { %s }', join( ' and ', map "($_)", @checks ), );
        ## no critic (ProhibitStringyEval)
        eval( $sub ) or _croak "could not build sub: $@\n\nCODE: $sub\n";
    };

    $return{name_generator} = sub {
        my ( $s, %a ) = @_;
        sprintf( '%s[%s]', $s, join q[,], map sprintf( "%s=>%s", $_, B::perlstring $a{$_} ), sort keys %a );
    };

    return ( %return, @_ );
}
































sub facetize {

    # maybe at some later date, just to annoy.
    # warnings::warnif( 'deprecated',
    #                     q{'facetize' is deprecated; use 'with_facets' instead.} );

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

    my %args = _with_facets( scalar caller(), \@_ );

    # old skool poke at the guts. need to do this in-place, and
    # Type::Tiny objects are pretty immutable, e.g. there is no
    # defined API to modify them after they're creaed.  which is why
    # this approach is deprecated.
    $self->{$_} = $args{$_} for keys %args;

    return if $self->is_anon;

    ## no critic( ProhibitNoStrict )
    no strict qw( refs );
    no warnings qw( redefine prototype );
    *{ $self->library . '::' . $self->name } = $type_to_coderef->( $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__