File Coverage

blib/lib/Types/Const.pm

Criterion	Covered	Total	%
statement	59	70	84.2
branch	12	20	60.0
condition	6	9	66.6
subroutine	20	21	95.2
pod			n/a
total	97	120	80.8

package Types::Const;

use v5.10;

use strict;
use warnings;

# ABSTRACT: Types that coerce references to read-only

use Type::Library
   -base,
   -declare => qw/ Const /;

use Const::Fast ();
use List::Util 1.33 ();
use Storable 3.06 (); # Regexp support
use Type::Coercion;
use Type::Tiny 1.002001;
use Type::Utils -all;
use Types::Standard qw/ -types is_ArrayRef is_HashRef is_ScalarRef /;
use Types::TypeTiny ();

# RECOMMEND PREREQ: Ref::Util::XS 0.100
# RECOMMEND PREREQ: Type::Tiny::XS

use namespace::autoclean 0.28;

our $VERSION = 'v0.4.2';


declare Const,
  as Ref,
  where   \&__is_readonly,
  message {
    return "$_ is not readonly";
  },
  constraint_generator => \&__constraint_generator,
  coercion_generator   => \&__coercion_generator;

coerce Const,
  from Ref,
  via \&__coerce_constant;

sub __coerce_constant {
    my $value = @_ ? $_[0] : $_;
    Const::Fast::_make_readonly( $value => 0 );
    return $value;
}

sub __is_readonly {
    if ( is_ArrayRef( $_[0] ) ) {
        return Internals::SvREADONLY( @{ $_[0] } )
          && List::Util::all { __is_readonly($_) } @{ $_[0] };
    }
    elsif ( is_HashRef( $_[0] ) ) {
        &Internals::hv_clear_placeholders( $_[0] );
        return Internals::SvREADONLY( %{ $_[0] } )
          && List::Util::all { __is_readonly($_) } values %{ $_[0] };
    }
    elsif ( is_ScalarRef( $_[0] )  ) {
        return Internals::SvREADONLY( ${ $_[0] } );
    }

    return Internals::SvREADONLY( $_[0] );
}

sub __constraint_generator {
    return Const unless @_;

    my $param = shift;
    Types::TypeTiny::TypeTiny->check($param)
        or _croak("Parameter to Const[`a] expected to be a type constraint; got $param");

    _croak("Only one parameter to Const[`a] expected; got @{[ 1 + @_ ]}.")
        if @_;

    my $psub = $param->constraint;

    return sub {
        return $psub->($_) && __is_readonly($_);
    };
}

sub __coercion_generator {
    my ( $parent, $child, $param ) = @_;

    return $parent->coercion unless $param->has_coercion;

    my $coercion = Type::Coercion->new( type_constraint => $child );

    my $coercable_item = $param->coercion->_source_type_union;

    $coercion->add_type_coercions(
        $parent => sub {
            my $value = @_ ? $_[0] : $_;
            my @new;
            for my $item (@$value) {
                return $value unless $coercable_item->check($item);
                push @new, $param->coerce($item);
            }
            return __coerce_constant(\@new);
        },
        );

    return $coercion;
}

__PACKAGE__->meta->make_immutable;

__END__