File Coverage

blib/lib/Type/Tiny/Class.pm
Criterion Covered Total %
statement 97 121 80.1
branch 25 42 59.5
condition 6 12 50.0
subroutine 28 31 90.3
pod 7 7 100.0
total 163 213 76.5


line stmt bran cond sub pod time code
1             package Type::Tiny::Class;
2              
3 34     34   216386 use 5.008001;
  34         148  
4 34     34   198 use strict;
  34         70  
  34         842  
5 34     34   174 use warnings;
  34         75  
  34         1646  
6              
7             BEGIN {
8 34     34   119 $Type::Tiny::Class::AUTHORITY = 'cpan:TOBYINK';
9 34         1453 $Type::Tiny::Class::VERSION = '2.004000';
10             }
11              
12             $Type::Tiny::Class::VERSION =~ tr/_//d;
13              
14 34     34   218 use Scalar::Util qw< blessed >;
  34         92  
  34         3585  
15              
16 1     1   5 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  1         4  
17              
18 34     34   1700 use Exporter::Tiny 1.004001 ();
  34         14014  
  34         784  
19 34     34   8257 use Type::Tiny::ConstrainedObject ();
  34         81  
  34         24415  
20             our @ISA = qw( Type::Tiny::ConstrainedObject Exporter::Tiny );
21              
22 3     3   8 sub _short_name { 'Class' }
23              
24             sub _exporter_fail {
25 2     2   360 my ( $class, $name, $opts, $globals ) = @_;
26 2         5 my $caller = $globals->{into};
27            
28 2 50       10 $opts->{name} = $name unless exists $opts->{name}; $opts->{name} =~ s/:://g;
  2         11  
29 2 100       8 $opts->{class} = $name unless exists $opts->{class};
30 2         8 my $type = $class->new($opts);
31            
32             $INC{'Type/Registry.pm'}
33             ? 'Type::Registry'->for_class( $caller )->add_type( $type )
34             : ( $Type::Registry::DELAYED{$caller}{$type->name} = $type )
35 2 50 33     35 unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
    50 33        
36 2         4 return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
  2         8  
37             }
38              
39             sub new {
40 182     182 1 2844 my $proto = shift;
41 182 100       693 return $proto->class->new( @_ ) if blessed $proto; # DWIM
42            
43 179 100       692 my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
  3         17  
44 179 100       460 _croak "Need to supply class name" unless exists $opts{class};
45            
46 178         235 if ( Type::Tiny::_USE_XS ) {
47             my $xsub =
48 178         870 Type::Tiny::XS::get_coderef_for( "InstanceOf[" . $opts{class} . "]" );
49 178 50       6402 $opts{compiled_type_constraint} = $xsub if $xsub;
50             }
51             elsif ( Type::Tiny::_USE_MOUSE ) {
52             require Mouse::Util::TypeConstraints;
53             my $maker = "Mouse::Util::TypeConstraints"->can( "generate_isa_predicate_for" );
54             $opts{compiled_type_constraint} = $maker->( $opts{class} ) if $maker;
55             }
56            
57 178         871 return $proto->SUPER::new( %opts );
58             } #/ sub new
59              
60 248     248 1 1587 sub class { $_[0]{class} }
61 670   66 670 1 2890 sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined }
62              
63 1229     1229 1 3705 sub has_inlined { !!1 }
64              
65 2183     2183   5244 sub _is_null_constraint { 0 }
66              
67             sub _build_constraint {
68 30     30   52 my $self = shift;
69 30         79 my $class = $self->class;
70 30 50   53   194 return sub { blessed( $_ ) and $_->isa( $class ) };
  53         396  
71             }
72              
73             sub _build_inlined {
74 113     113   199 my $self = shift;
75 113         214 my $class = $self->class;
76            
77 113         192 my $xsub;
78 113         440 $xsub = Type::Tiny::XS::get_subname_for( "InstanceOf[$class]" )
79             if Type::Tiny::_USE_XS;
80            
81             sub {
82 670     670   888 my $var = $_[1];
83             return
84 670 100       1410 qq{do { use Scalar::Util (); Scalar::Util::blessed($var) and $var->isa(q[$class]) }}
85             if $Type::Tiny::AvoidCallbacks;
86 574 50       1882 return "$xsub\($var\)"
87             if $xsub;
88 0         0 qq{Scalar::Util::blessed($var) and $var->isa(q[$class])};
89 113         1450 };
90             } #/ sub _build_inlined
91              
92             sub _build_default_message {
93 34     34   268 no warnings 'uninitialized';
  34         97  
  34         16684  
94 1     1   3 my $self = shift;
95 1         2 my $c = $self->class;
96             return sub {
97 0     0   0 sprintf '%s did not pass type constraint (not isa %s)',
98             Type::Tiny::_dd( $_[0] ), $c;
99             }
100 1 50       6 if $self->is_anon;
101 1         5 my $name = "$self";
102             return sub {
103 1     1   5 sprintf '%s did not pass type constraint "%s" (not isa %s)',
104             Type::Tiny::_dd( $_[0] ), $name, $c;
105 1         8 };
106             } #/ sub _build_default_message
107              
108             sub _instantiate_moose_type {
109 0     0   0 my $self = shift;
110 0         0 my %opts = @_;
111 0         0 delete $opts{parent};
112 0         0 delete $opts{constraint};
113 0         0 delete $opts{inlined};
114 0         0 require Moose::Meta::TypeConstraint::Class;
115 0         0 return "Moose::Meta::TypeConstraint::Class"
116             ->new( %opts, class => $self->class );
117             } #/ sub _instantiate_moose_type
118              
119             sub plus_constructors {
120 0     0 1 0 my $self = shift;
121            
122 0 0       0 unless ( @_ ) {
123 0         0 require Types::Standard;
124 0         0 push @_, Types::Standard::HashRef(), "new";
125             }
126            
127 0         0 require B;
128 0         0 require Types::TypeTiny;
129            
130 0         0 my $class = B::perlstring( $self->class );
131            
132 0         0 my @r;
133 0         0 while ( @_ ) {
134 0         0 my $source = shift;
135 0 0       0 Types::TypeTiny::is_TypeTiny( $source )
136             or _croak "Expected type constraint; got $source";
137            
138 0         0 my $constructor = shift;
139 0 0       0 Types::TypeTiny::is_StringLike( $constructor )
140             or _croak "Expected string; got $constructor";
141            
142 0         0 push @r, $source, sprintf( '%s->%s($_)', $class, $constructor );
143             } #/ while ( @_ )
144            
145 0         0 return $self->plus_coercions( \@r );
146             } #/ sub plus_constructors
147              
148             sub parent {
149 284   66 284 1 1634 $_[0]{parent} ||= $_[0]->_build_parent;
150             }
151              
152             sub _build_parent {
153 88     88   141 my $self = shift;
154 88         188 my $class = $self->class;
155            
156             # Some classes (I'm looking at you, Math::BigFloat) include a class in
157             # their @ISA to inherit methods, but then override isa() to return false,
158             # so that they don't appear to be a subclass.
159             #
160             # In these cases, we don't want to list the parent class as a parent
161             # type constraint.
162             #
163             my @isa = grep $class->isa( $_ ),
164 34     34   278 do { no strict "refs"; no warnings; @{"$class\::ISA"} };
  34     34   69  
  34         1345  
  34         207  
  34         78  
  34         6449  
  88         137  
  88         109  
  88         631  
165            
166 88 100       279 if ( @isa == 0 ) {
167 60         2035 require Types::Standard;
168 60         215 return Types::Standard::Object();
169             }
170            
171 28 100       86 if ( @isa == 1 ) {
172 24         109 return ref( $self )->new( class => $isa[0] );
173             }
174            
175 4         1011 require Type::Tiny::Intersection;
176 4         26 "Type::Tiny::Intersection"->new(
177             type_constraints => [ map ref( $self )->new( class => $_ ), @isa ],
178             );
179             } #/ sub _build_parent
180              
181             *__get_linear_isa_dfs =
182             eval { require mro }
183             ? \&mro::get_linear_isa
184             : sub {
185 34     34   283 no strict 'refs';
  34         75  
  34         10174  
186            
187             my $classname = shift;
188             my @lin = ( $classname );
189             my %stored;
190            
191             foreach my $parent ( @{"$classname\::ISA"} ) {
192             my $plin = __get_linear_isa_dfs( $parent );
193             foreach ( @$plin ) {
194             next if exists $stored{$_};
195             push( @lin, $_ );
196             $stored{$_} = 1;
197             }
198             }
199            
200             return \@lin;
201             };
202            
203             sub validate_explain {
204 1     1 1 2 my $self = shift;
205 1         3 my ( $value, $varname ) = @_;
206 1 50       3 $varname = '$_' unless defined $varname;
207            
208 1 50       12 return undef if $self->check( $value );
209 1 50       6 return ["Not a blessed reference"] unless blessed( $value );
210            
211 1         2 my @isa = @{ __get_linear_isa_dfs( ref $value ) };
  1         9  
212            
213 1 50       5 my $display_var = $varname eq q{$_} ? '' : sprintf( ' (in %s)', $varname );
214            
215 1         516 require Type::Utils;
216             return [
217 1         8 sprintf( '"%s" requires that the reference isa %s', $self, $self->class ),
218             sprintf(
219             'The reference%s isa %s', $display_var, Type::Utils::english_list( @isa )
220             ),
221             ];
222             } #/ sub validate_explain
223              
224             1;
225              
226             __END__