File Coverage

blib/lib/Type/Tiny/ConstrainedObject.pm
Criterion Covered Total %
statement 35 37 97.3
branch 3 4 75.0
condition n/a
subroutine 12 13 92.3
pod 6 6 100.0
total 56 60 95.0


line stmt bran cond sub pod time code
1             package Type::Tiny::ConstrainedObject;
2              
3 45     45   1165 use 5.008001;
  45         160  
4 45     45   248 use strict;
  45         88  
  45         993  
5 45     45   233 use warnings;
  45         89  
  45         2074  
6              
7             BEGIN {
8 45     45   283 $Type::Tiny::ConstrainedObject::AUTHORITY = 'cpan:TOBYINK';
9 45         3263 $Type::Tiny::ConstrainedObject::VERSION = '2.004000';
10             }
11              
12             $Type::Tiny::ConstrainedObject::VERSION =~ tr/_//d;
13              
14 9     9   51 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  9         46  
15              
16 45     45   3618 use Type::Tiny ();
  45         118  
  45         31114  
17             our @ISA = 'Type::Tiny';
18              
19             my %errlabel = (
20             parent => 'a parent',
21             constraint => 'a constraint coderef',
22             inlined => 'an inlining coderef',
23             );
24              
25             sub new {
26 280     280 1 539 my $proto = shift;
27 280 50       1017 my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
  0         0  
28 280         629 for my $key ( qw/ parent constraint inlined / ) {
29 831 100       1838 next unless exists $opts{$key};
30             _croak(
31             '%s type constraints cannot have %s passed to the constructor',
32             $proto->_short_name,
33 9         28 $errlabel{$key},
34             );
35             }
36 271         1186 $proto->SUPER::new( %opts );
37             } #/ sub new
38              
39             sub has_parent {
40 7648     7648 1 19256 !!1;
41             }
42              
43             sub parent {
44 244     244 1 2925 require Types::Standard;
45 244         768 Types::Standard::Object();
46             }
47              
48             sub _short_name {
49 0     0   0 die "subclasses must implement this"; # uncoverable statement
50             }
51              
52             my $i = 0;
53             my $_where_expressions = sub {
54             my $self = shift;
55             my $name = shift;
56             $name ||= "where expression check";
57             my ( %env, @codes );
58             while ( @_ ) {
59             my $expr = shift;
60             my $constraint = shift;
61             if ( !ref $constraint ) {
62             push @codes, sprintf( 'do { local $_ = %s; %s }', $expr, $constraint );
63             }
64             else {
65             require Types::Standard;
66             my $type =
67             Types::Standard::is_RegexpRef( $constraint )
68             ? Types::Standard::StrMatch()->of( $constraint )
69             : Types::TypeTiny::to_TypeTiny( $constraint );
70             if ( $type->can_be_inlined ) {
71             push @codes,
72             sprintf(
73             'do { my $tmp = %s; %s }', $expr,
74             $type->inline_check( '$tmp' )
75             );
76             }
77             else {
78             ++$i;
79             $env{ '$chk' . $i } = do { my $chk = $type->compiled_check; \$chk };
80             push @codes, sprintf( '$chk%d->(%s)', $i, $expr );
81             }
82             } #/ else [ if ( !ref $constraint )]
83             } #/ while ( @_ )
84            
85             if ( keys %env ) {
86            
87             # cannot inline
88             my $sub = Eval::TypeTiny::eval_closure(
89             source =>
90             sprintf( 'sub ($) { local $_ = shift; %s }', join( q( and ), @codes ) ),
91             description => sprintf( '%s for %s', $name, $self->name ),
92             environment => \%env,
93             );
94             return $self->where( $sub );
95             } #/ if ( keys %env )
96             else {
97             return $self->where( join( q( and ), @codes ) );
98             }
99             };
100              
101             sub stringifies_to {
102 16     16 1 749 my $self = shift;
103 16         44 my ( $constraint ) = @_;
104 16         63 $self->$_where_expressions( "stringification check", q{"$_"}, $constraint );
105             }
106              
107             sub numifies_to {
108 15     15 1 167 my $self = shift;
109 15         41 my ( $constraint ) = @_;
110 15         63 $self->$_where_expressions( "numification check", q{0+$_}, $constraint );
111             }
112              
113             sub with_attribute_values {
114 24     24 1 381 my $self = shift;
115 24         99 my %constraint = @_;
116             $self->$_where_expressions(
117             "attributes check",
118 24         140 map { my $attr = $_; qq{\$_->$attr} => $constraint{$attr} }
  48         90  
  48         190  
119             sort keys %constraint,
120             );
121             }
122              
123             1;
124              
125             __END__