File Coverage

lib/Unexpected/Types.pm

Criterion	Covered	Total	%
statement	25	25	100.0
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	34	100.0

package Unexpected::Types;

use strict;
use warnings;

use English               qw( -no_match_vars );
use Module::Runtime       qw( is_module_name require_module );
use Scalar::Util          qw( blessed );
use Type::Library             -base, -declare =>
                          qw( LoadableClass NonEmptySimpleStr
                              NonNumericSimpleStr NonZeroPositiveInt
                              NonZeroPositiveNum PositiveInt PositiveNum
                              RequestFactory SimpleStr Tracer );
use Type::Utils           qw( as coerce extends from
                              inline_as message subtype via where );
use Unexpected::Functions qw( inflate_message );

BEGIN { extends 'Types::Standard' };

my $LOADABLE_CLASS_ERROR;

$Error::TypeTiny::CarpInternal{ 'Sub::Quote' }++;
$Error::TypeTiny::CarpInternal{ 'Unexpected::TraitFor::Throwing' }++;

# Private functions
my $_constraint_for_loadable_class = sub {
   my $class = shift; is_module_name( $class ) or return 0;

   local $EVAL_ERROR; eval { require_module( $class ) };

   $LOADABLE_CLASS_ERROR = $EVAL_ERROR;

   return $EVAL_ERROR ? 0 : 1;
};

my $_exception_message_for_object_reference = sub {
   return inflate_message( 'String [_1] is not an object reference', $_[ 0 ] );
};

my $_exception_message_for_req_factory = sub {
   blessed $_[ 0 ] and return inflate_message
      'Object [_1] is missing the new_from_simple_request method',
      blessed $_[ 0 ];

   return $_exception_message_for_object_reference->( $_[ 0 ] );
};

my $_exception_message_for_tracer = sub {
   blessed $_[ 0 ] and return inflate_message
      'Object [_1] is missing a frames method', blessed $_[ 0 ];

   return $_exception_message_for_object_reference->( $_[ 0 ] );
};

# Types
subtype NonEmptySimpleStr, as Str,
   inline_as {
      $_[ 0 ]->parent->inline_check( $_ )
         ." and length $_ > 0 and length $_ < 255 and $_ !~ m{ [\\n] }mx" },
   message   {
      inflate_message
         ( 'Attribute value [_1] is not a non empty simple string', $_ ) },
   where     { length $_ > 0 and length $_ < 255 and $_ !~ m{ [\n] }mx };

subtype NonZeroPositiveInt, as Int,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )." and $_ > 0" },
   message   {
      inflate_message
         ( 'Attribute value [_1] is not a non zero positive integer', $_ ) },
   where     { $_ > 0 };

subtype NonZeroPositiveNum, as Num,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )." and $_ > 0" },
   message   {
      inflate_message
         ( 'Attribute value [_1] is not a non zero positive number', $_ ) },
   where     { $_ > 0 };

subtype PositiveInt, as Int,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )." and $_ >= 0" },
   message   { inflate_message
                  ( 'Attribute value [_1] is not a positive integer', $_ ) },
   where     { $_ >= 0 };

subtype PositiveNum, as Num,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )." and $_ >= 0" },
   message   { inflate_message
                  ( 'Attribute value [_1] is not a positive number', $_ ) },
   where     { $_ >= 0 };

subtype RequestFactory, as Object,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )
                  ." and $_->can( 'new_from_simple_request' )" },
   message   { $_exception_message_for_req_factory->( $_ ) },
   where     { $_->can( 'new_from_simple_request' ) };

subtype SimpleStr, as Str,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )
                  ." and length $_ < 255 and $_ !~ m{ [\\n] }mx" },
   message   { inflate_message
                  ( 'Attribute value [_1] is not a simple string', $_ ) },
   where     { length $_ < 255 and $_ !~ m{ [\n] }mx };

subtype Tracer, as Object,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )." and $_->can( 'frames' )" },
   message   { $_exception_message_for_tracer->( $_ ) },
   where     { $_->can( 'frames' ) };


subtype LoadableClass, as NonEmptySimpleStr,
   message   { inflate_message( 'String [_1] is not a loadable class: [_2]',
                                $_, $LOADABLE_CLASS_ERROR ) },
   where     { $_constraint_for_loadable_class->( $_ ) };

subtype NonNumericSimpleStr, as SimpleStr,
   inline_as { $_[ 0 ]->parent->inline_check( $_ )." and $_ !~ m{ \\d+ }mx" },
   message   {
      inflate_message
         ( 'Attribute value [_1] is not a non numeric simple string', $_ ) },
   where     { $_ !~ m{ \d+ }mx };

1;

__END__