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   135 use 5.008001;
  6         23  
6 6     6   34 use strict;
  6         34  
  6         159  
7 6     6   32 use warnings;
  6         13  
  6         395  
8              
9             BEGIN {
10 6     6   34 $Types::Standard::ScalarRef::AUTHORITY = 'cpan:TOBYINK';
11 6         261 $Types::Standard::ScalarRef::VERSION = '2.004000';
12             }
13              
14             $Types::Standard::ScalarRef::VERSION =~ tr/_//d;
15              
16 6     6   62 use Types::Standard ();
  6         13  
  6         117  
17 6     6   30 use Types::TypeTiny ();
  6         12  
  6         392  
18              
19 2     2   38 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  2         18  
20              
21 6     6   38 no warnings;
  6         16  
  6         4240  
22              
23             sub __constraint_generator {
24 13 100   13   60 return Types::Standard::ScalarRef unless @_;
25            
26 12         27 my $param = shift;
27 12 100       236 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   35 my $ref = shift;
33 19 100       52 $param->check( $$ref ) || return;
34 10         43 return !!1;
35 10         59 };
36             } #/ sub __constraint_generator
37              
38             sub __inline_generator {
39 10     10   18 my $param = shift;
40 10 50       31 return unless $param->can_be_inlined;
41             return sub {
42 67     67   109 my $v = $_[1];
43 67         243 my $param_check = $param->inline_check( "\${$v}" );
44 67         242 "(ref($v) eq 'SCALAR' or ref($v) eq 'REF') and $param_check";
45 10         62 };
46             }
47              
48             sub __deep_explanation {
49 1     1   3 my ( $type, $value, $varname ) = @_;
50 1         3 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         10 @{ $param->validate_explain( $item, sprintf( '${%s}', $varname ) ) },
  1         8  
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   26 my ( $parent, $child, $param ) = @_;
68 5 100       32 return unless $param->has_coercion;
69            
70 4         18 my $coercable_item = $param->coercion->_source_type_union;
71 4         23 my $C = "Type::Coercion"->new( type_constraint => $child );
72            
73 4 100 66     28 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   6 my @code;
77 3         6 push @code, 'do { my ($orig, $return_orig, $new) = ($_, 0);';
78 3         6 push @code, 'for ($$orig) {';
79 3         12 push @code,
80             sprintf(
81             '++$return_orig && last unless (%s);',
82             $coercable_item->inline_check( '$_' )
83             );
84 3         17 push @code,
85             sprintf(
86             '$new = (%s);',
87             $param->coercion->inline_coercion( '$_' )
88             );
89 3         24 push @code, '}';
90 3         8 push @code, '$return_orig ? $orig : \\$new';
91 3         11 push @code, '}';
92 3         52 "@code";
93             }
94 3         38 );
95             } #/ if ( $param->coercion->...)
96             else {
97             $C->add_type_coercions(
98             $parent => sub {
99 2 50   2   57 my $value = @_ ? $_[0] : $_;
100 2         3 my $new;
101 2         5 for my $item ( $$value ) {
102 2 100       7 return $value unless $coercable_item->check( $item );
103 1         21 $new = $param->coerce( $item );
104             }
105 1         23 return \$new;
106             },
107 1         5 );
108             } #/ else [ if ( $param->coercion->...)]
109            
110 4         16 return $C;
111             } #/ sub __coercion_generator
112              
113             1;