File Coverage

blib/lib/Salvation/TC/Meta/Type/Parameterized.pm
Criterion Covered Total %
statement 56 65 86.1
branch 16 24 66.6
condition 3 9 33.3
subroutine 15 16 93.7
pod 8 8 100.0
total 98 122 80.3


line stmt bran cond sub pod time code
1             package Salvation::TC::Meta::Type::Parameterized;
2              
3             =head1 NAME
4              
5             Salvation::TC::Meta::Type::Parameterized - Базовый класс для параметризованных типов
6              
7             =cut
8              
9 4     4   20 use strict;
  4         6  
  4         117  
10 4     4   14 use warnings;
  4         6  
  4         88  
11              
12 4     4   14 use base 'Salvation::TC::Meta::Type';
  4         4  
  4         316  
13              
14 4     4   18 use Scalar::Util 'blessed';
  4         6  
  4         200  
15              
16 4     4   19 use Salvation::TC::Exception::WrongType::TC ();
  4         5  
  4         2383  
17              
18             =head1 METHODS
19              
20             =cut
21              
22             =head2 new()
23              
24             =cut
25              
26             sub new {
27              
28 46     46 1 139 my ( $proto, %args ) = @_;
29              
30 46 50       94 die( 'Parameterized type metaclass must have inner type' ) unless( defined $args{ 'inner' } );
31              
32 46 50 33     286 unless( blessed $args{ 'inner' } && $args{ 'inner' } -> isa( 'Salvation::TC::Meta::Type' ) ) {
33              
34 0         0 die( 'Inner type must be a Salvation::TC::Meta::Type' );
35             }
36              
37 46         183 my $self = $proto -> SUPER::new( %args );
38              
39 46         191 $self -> { 'container_validator' } = delete( $self -> { 'validator' } );
40 46         102 $self -> { 'validator' } = $self -> build_validator();
41              
42 46         345 return $self;
43             }
44              
45             =head2 inner()
46              
47             =cut
48              
49             sub inner {
50              
51 55     55 1 51 my ( $self ) = @_;
52              
53 55         98 return $self -> { 'inner' };
54             }
55              
56             =head2 iterate( Any $value, CodeRef $code )
57              
58             =cut
59              
60             sub iterate {
61              
62 0     0 1 0 my ( $self, $value, $code ) = @_;
63 0         0 my $clone = undef;
64              
65 0         0 $code -> ( $value, undef, \$clone );
66              
67 0         0 return $clone;
68             }
69              
70             =head2 container_validator()
71              
72             =cut
73              
74             sub container_validator {
75              
76 98     98 1 79 my ( $self ) = @_;
77              
78 98         191 return $self -> { 'container_validator' };
79             }
80              
81             =head2 check_container( Any $value )
82              
83             =cut
84              
85             sub check_container {
86              
87 98     98 1 89 my ( $self, $value ) = @_;
88              
89 98         151 return $self -> container_validator() -> ( $value );
90             }
91              
92             =head2 build_validator()
93              
94             =cut
95              
96             sub build_validator {
97              
98 46     46 1 46 my ( $self ) = @_;
99              
100 46         88 my $item_type = $self -> inner();
101              
102             return sub {
103              
104 74     74   72 my ( $value ) = @_;
105              
106 74         60 eval { $self -> check_container( $value ) };
  74         120  
107              
108 74 100       138 if( $@ ) {
109              
110 11 50 33     75 if( blessed( $@ ) && $@ -> isa( 'Salvation::TC::Exception::WrongType' ) ) {
111              
112 11 100       31 Salvation::TC::Exception::WrongType::TC -> throw(
113             type => $self -> name(), value => $value,
114             ( $@ -> isa( 'Salvation::TC::Exception::WrongType::TC' ) ? (
115             prev => $@,
116             ) : () )
117             );
118              
119             } else {
120              
121 0         0 die( $@ );
122             }
123             };
124              
125             $self -> iterate( $value, sub {
126              
127             # my ( $item, $key ) = @_;
128              
129 86         73 eval { $item_type -> check( $_[ 0 ] ) };
  86         183  
130              
131 86 100       264 if( $@ ) {
132              
133 26 50 33     143 if( blessed( $@ ) && $@ -> isa( 'Salvation::TC::Exception::WrongType' ) ) {
134              
135 26 100       57 Salvation::TC::Exception::WrongType::TC -> throw(
136             type => $self -> name(), value => $value,
137             prev => Salvation::TC::Exception::WrongType::TC -> new(
138             type => $item_type -> name(),
139             value => $_[ 0 ],
140             param_name => $_[ 1 ],
141             ( $@ -> isa( 'Salvation::TC::Exception::WrongType::TC' ) ? (
142             prev => $@,
143             ) : () )
144             )
145             );
146              
147             } else {
148              
149 0         0 die( $@ );
150             }
151             };
152 63         290 } );
153              
154 37         191 return 1;
155 46         192 };
156             }
157              
158             =head2 sign( ArrayRef signature, HashRef options )
159              
160             Генерирует валидатор для текущего типа на основе подписи.
161              
162             =cut
163              
164             sub sign {
165              
166 4     4 1 5 my ( $self, $signature, $options ) = @_;
167              
168 4         11 my $signed_type_generator = $self -> signed_type_generator();
169              
170 4 50       11 unless( defined $signed_type_generator ) {
171              
172 0         0 die( sprintf( 'Type %s cannot be signed', $self -> name() ) )
173             }
174              
175 4         10 my $signed_validator = $signed_type_generator -> ( $signature, $options );
176              
177             return sub {
178              
179 10 50   10   17 $self -> check_container( $_[ 0 ] ) && $signed_validator -> ( $_[ 0 ] )
180 4         35 };
181             }
182              
183             =head2 length_checker( Int $min, Maybe[Int] $max )
184              
185             Генерирует валидатор для текущего типа на основе спецификации длины.
186              
187             =cut
188              
189             sub length_checker {
190              
191 5     5 1 9 my ( $self, $min, $max ) = @_;
192              
193 5         12 my $length_type_generator = $self -> length_type_generator();
194              
195 5 50       9 unless( defined $length_type_generator ) {
196              
197 0         0 die( sprintf( 'Length of type %s could not be checked', $self -> name() ) );
198             }
199              
200 5         12 my $length_validator = $length_type_generator -> ( $min, $max );
201              
202             return sub {
203              
204 14 50   14   24 $self -> check_container( $_[ 0 ] ) && $length_validator -> ( $_[ 0 ] )
205 5         21 };
206             }
207              
208             1;
209              
210             __END__