File Coverage

lib/Types/Standard/ScalarRef.pm
Criterion Covered Total %
statement 63 64 100.0
branch 15 18 83.3
condition 2 3 66.6
subroutine 16 16 100.0
pod n/a
total 96 101 96.0


line stmt bran cond sub pod time code
1             # INTERNAL MODULE: guts for ScalarRef type from Types::Standard.
2              
3             package Types::Standard::ScalarRef;
4              
5 6     6   128 use 5.008001;
  6         24  
6 6     6   34 use strict;
  6         18  
  6         144  
7 6     6   27 use warnings;
  6         12  
  6         377  
8              
9             BEGIN {
10 6     6   28 $Types::Standard::ScalarRef::AUTHORITY = 'cpan:TOBYINK';
11 6         245 $Types::Standard::ScalarRef::VERSION = '2.003_000';
12             }
13              
14             $Types::Standard::ScalarRef::VERSION =~ tr/_//d;
15              
16 6     6   45 use Types::Standard ();
  6         18  
  6         84  
17 6     6   37 use Types::TypeTiny ();
  6         12  
  6         403  
18              
19 2     2   30 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  2         14  
20              
21 6     6   36 no warnings;
  6         12  
  6         4191  
22              
23             sub __constraint_generator {
24 13 100   13   50 return Types::Standard::ScalarRef unless @_;
25            
26 12         25 my $param = shift;
27 12 100       245 Types::TypeTiny::is_TypeTiny( $param )
28             or _croak(
29             "Parameter to ScalarRef[`a] expected to be a type constraint; got $param" );
30            
31             return sub {
32 19     19   37 my $ref = shift;
33 19 100       53 $param->check( $$ref ) || return;
34 10         43 return !!1;
35 10         55 };
36             } #/ sub __constraint_generator
37              
38             sub __inline_generator {
39 10     10   21 my $param = shift;
40 10 50       37 return unless $param->can_be_inlined;
41             return sub {
42 67     67   141 my $v = $_[1];
43 67         244 my $param_check = $param->inline_check( "\${$v}" );
44 67         248 "(ref($v) eq 'SCALAR' or ref($v) eq 'REF') and $param_check";
45 10         58 };
46             }
47              
48             sub __deep_explanation {
49 1     1   2 my ( $type, $value, $varname ) = @_;
50 1         4 my $param = $type->parameters->[0];
51            
52 1         3 for my $item ( $$value ) {
53 1 50       3 next if $param->check( $item );
54             return [
55             sprintf(
56             '"%s" constrains the referenced scalar value with "%s"', $type, $param
57             ),
58 1         4 @{ $param->validate_explain( $item, sprintf( '${%s}', $varname ) ) },
  1         4  
59             ];
60             }
61            
62             # This should never happen...
63 0         0 return; # uncoverable statement
64             } #/ sub __deep_explanation
65              
66             sub __coercion_generator {
67 5     5   14 my ( $parent, $child, $param ) = @_;
68 5 100       22 return unless $param->has_coercion;
69            
70 4         14 my $coercable_item = $param->coercion->_source_type_union;
71 4         25 my $C = "Type::Coercion"->new( type_constraint => $child );
72            
73 4 100 66     14 if ( $param->coercion->can_be_inlined and $coercable_item->can_be_inlined ) {
74             $C->add_type_coercions(
75             $parent => Types::Standard::Stringable {
76 3     3   5 my @code;
77 3         7 push @code, 'do { my ($orig, $return_orig, $new) = ($_, 0);';
78 3         7 push @code, 'for ($$orig) {';
79 3         13 push @code,
80             sprintf(
81             '++$return_orig && last unless (%s);',
82             $coercable_item->inline_check( '$_' )
83             );
84 3         15 push @code,
85             sprintf(
86             '$new = (%s);',
87             $param->coercion->inline_coercion( '$_' )
88             );
89 3         12 push @code, '}';
90 3         6 push @code, '$return_orig ? $orig : \\$new';
91 3         10 push @code, '}';
92 3         35 "@code";
93             }
94 3         21 );
95             } #/ if ( $param->coercion->...)
96             else {
97             $C->add_type_coercions(
98             $parent => sub {
99 2 50   2   59 my $value = @_ ? $_[0] : $_;
100 2         5 my $new;
101 2         4 for my $item ( $$value ) {
102 2 100       8 return $value unless $coercable_item->check( $item );
103 1         22 $new = $param->coerce( $item );
104             }
105 1         28 return \$new;
106             },
107 1         5 );
108             } #/ else [ if ( $param->coercion->...)]
109            
110 4         14 return $C;
111             } #/ sub __coercion_generator
112              
113             1;