line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ABSTRACT: Data Validation Engine for Validation::Class Classes |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Validation::Class::Prototype; |
4
|
|
|
|
|
|
|
|
5
|
108
|
|
|
108
|
|
1199
|
use 5.10.0; |
|
108
|
|
|
|
|
346
|
|
6
|
108
|
|
|
108
|
|
555
|
use strict; |
|
108
|
|
|
|
|
192
|
|
|
108
|
|
|
|
|
2292
|
|
7
|
108
|
|
|
108
|
|
1591
|
use warnings; |
|
108
|
|
|
|
|
250
|
|
|
108
|
|
|
|
|
7562
|
|
8
|
|
|
|
|
|
|
|
9
|
108
|
|
|
108
|
|
69470
|
use Validation::Class::Configuration; |
|
108
|
|
|
|
|
332
|
|
|
108
|
|
|
|
|
3710
|
|
10
|
108
|
|
|
108
|
|
699
|
use Validation::Class::Directives; |
|
108
|
|
|
|
|
203
|
|
|
108
|
|
|
|
|
2120
|
|
11
|
108
|
|
|
108
|
|
563
|
use Validation::Class::Listing; |
|
108
|
|
|
|
|
198
|
|
|
108
|
|
|
|
|
2303
|
|
12
|
108
|
|
|
108
|
|
553
|
use Validation::Class::Mapping; |
|
108
|
|
|
|
|
199
|
|
|
108
|
|
|
|
|
2192
|
|
13
|
108
|
|
|
108
|
|
61387
|
use Validation::Class::Params; |
|
108
|
|
|
|
|
288
|
|
|
108
|
|
|
|
|
2765
|
|
14
|
108
|
|
|
108
|
|
695
|
use Validation::Class::Fields; |
|
108
|
|
|
|
|
216
|
|
|
108
|
|
|
|
|
2332
|
|
15
|
108
|
|
|
108
|
|
522
|
use Validation::Class::Errors; |
|
108
|
|
|
|
|
194
|
|
|
108
|
|
|
|
|
2135
|
|
16
|
108
|
|
|
108
|
|
666
|
use Validation::Class::Util; |
|
108
|
|
|
|
|
196
|
|
|
108
|
|
|
|
|
489
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $VERSION = '7.900057'; # VERSION |
19
|
|
|
|
|
|
|
|
20
|
108
|
|
|
108
|
|
593
|
use List::MoreUtils 'uniq', 'firstval'; |
|
108
|
|
|
|
|
214
|
|
|
108
|
|
|
|
|
1070
|
|
21
|
108
|
|
|
108
|
|
57803
|
use Hash::Flatten 'flatten', 'unflatten'; |
|
108
|
|
|
|
|
237
|
|
|
108
|
|
|
|
|
6824
|
|
22
|
108
|
|
|
108
|
|
570
|
use Module::Runtime 'use_module'; |
|
108
|
|
|
|
|
203
|
|
|
108
|
|
|
|
|
956
|
|
23
|
108
|
|
|
108
|
|
5006
|
use Module::Find 'findallmod'; |
|
108
|
|
|
|
|
201
|
|
|
108
|
|
|
|
|
5084
|
|
24
|
108
|
|
|
108
|
|
538
|
use Scalar::Util 'weaken'; |
|
108
|
|
|
|
|
199
|
|
|
108
|
|
|
|
|
5190
|
|
25
|
108
|
|
|
108
|
|
530
|
use Hash::Merge 'merge'; |
|
108
|
|
|
|
|
228
|
|
|
108
|
|
|
|
|
5914
|
|
26
|
108
|
|
|
108
|
|
537
|
use Carp 'confess'; |
|
108
|
|
|
|
|
209
|
|
|
108
|
|
|
|
|
4404
|
|
27
|
108
|
|
|
108
|
|
10377
|
use Clone 'clone'; |
|
108
|
|
|
|
|
41515
|
|
|
108
|
|
|
|
|
555074
|
|
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
my $_registry = Validation::Class::Mapping->new; # prototype registry |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
hold 'attributes' => sub { Validation::Class::Mapping->new }; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
hold 'builders' => sub { Validation::Class::Listing->new }; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
hold 'configuration' => sub { Validation::Class::Configuration->new }; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
hold 'directives' => sub { Validation::Class::Mapping->new }; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
hold 'documents' => sub { Validation::Class::Mapping->new }; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
hold 'errors' => sub { Validation::Class::Errors->new }; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
hold 'events' => sub { Validation::Class::Mapping->new }; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
hold 'fields' => sub { Validation::Class::Fields->new }; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
has 'filtering' => 'pre'; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
hold 'filters' => sub { Validation::Class::Mapping->new }; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
has 'ignore_failure' => '1'; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
has 'ignore_intervention' => '0'; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
has 'ignore_unknown' => '0'; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
hold 'messages' => sub { Validation::Class::Mapping->new }; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
hold 'methods' => sub { Validation::Class::Mapping->new }; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
hold 'mixins' => sub { Validation::Class::Mixins->new }; |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
hold 'package' => sub { undef }; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
hold 'params' => sub { Validation::Class::Params->new }; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
hold 'profiles' => sub { Validation::Class::Mapping->new }; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
hold 'queued' => sub { Validation::Class::Listing->new }; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
has 'report_failure' => 0; |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
has 'report_unknown' => 0; |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
hold 'settings' => sub { Validation::Class::Mapping->new }; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
has 'validated' => 0; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
has 'stashed' => sub { Validation::Class::Mapping->new }; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
Hash::Merge::specify_behavior( |
107
|
|
|
|
|
|
|
{ |
108
|
|
|
|
|
|
|
'SCALAR' => { |
109
|
|
|
|
|
|
|
'SCALAR' => sub { |
110
|
|
|
|
|
|
|
$_[1] |
111
|
|
|
|
|
|
|
}, |
112
|
|
|
|
|
|
|
'ARRAY' => sub { |
113
|
|
|
|
|
|
|
[$_[0], @{$_[1]}] |
114
|
|
|
|
|
|
|
}, |
115
|
|
|
|
|
|
|
'HASH' => sub { |
116
|
|
|
|
|
|
|
$_[1] |
117
|
|
|
|
|
|
|
}, |
118
|
|
|
|
|
|
|
}, |
119
|
|
|
|
|
|
|
'ARRAY' => { |
120
|
|
|
|
|
|
|
'SCALAR' => sub { |
121
|
|
|
|
|
|
|
[@{$_[0]}, $_[1]] |
122
|
|
|
|
|
|
|
}, |
123
|
|
|
|
|
|
|
'ARRAY' => sub { |
124
|
|
|
|
|
|
|
[@{$_[0]}, @{$_[1]}] |
125
|
|
|
|
|
|
|
}, |
126
|
|
|
|
|
|
|
'HASH' => sub { |
127
|
|
|
|
|
|
|
[@{$_[0]}, $_[1]] |
128
|
|
|
|
|
|
|
}, |
129
|
|
|
|
|
|
|
}, |
130
|
|
|
|
|
|
|
'HASH' => { |
131
|
|
|
|
|
|
|
'SCALAR' => sub { |
132
|
|
|
|
|
|
|
$_[1] |
133
|
|
|
|
|
|
|
}, |
134
|
|
|
|
|
|
|
'ARRAY' => sub { |
135
|
|
|
|
|
|
|
$_[1] |
136
|
|
|
|
|
|
|
}, |
137
|
|
|
|
|
|
|
'HASH' => sub { |
138
|
|
|
|
|
|
|
Hash::Merge::_merge_hashes($_[0], $_[1]) |
139
|
|
|
|
|
|
|
}, |
140
|
|
|
|
|
|
|
}, |
141
|
|
|
|
|
|
|
}, |
142
|
|
|
|
|
|
|
# based on RIGHT_PRECEDENT, STORAGE_PRECEDENT and RETAINMENT_PRECEDENT |
143
|
|
|
|
|
|
|
# ... this is intended to DWIM in the context of role-settings-merging |
144
|
|
|
|
|
|
|
'ROLE_PRECEDENT' |
145
|
|
|
|
|
|
|
); |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub new { |
148
|
|
|
|
|
|
|
|
149
|
159
|
|
|
159
|
0
|
457
|
my $class = shift; |
150
|
|
|
|
|
|
|
|
151
|
159
|
|
|
|
|
749
|
my $arguments = $class->build_args(@_); |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
confess |
154
|
|
|
|
|
|
|
"The $class class must be instantiated with a parameter named package ". |
155
|
|
|
|
|
|
|
"whose value is the name of the associated package" unless defined |
156
|
159
|
50
|
33
|
|
|
1723
|
$arguments->{package} && $arguments->{package} =~ /\w/ |
157
|
|
|
|
|
|
|
; |
158
|
|
|
|
|
|
|
|
159
|
159
|
|
|
|
|
422
|
my $self = bless $arguments, $class; |
160
|
|
|
|
|
|
|
|
161
|
159
|
|
|
|
|
1061
|
$_registry->add($arguments->{package}, $self); |
162
|
|
|
|
|
|
|
|
163
|
159
|
|
|
|
|
490
|
return $self; |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub apply_filter { |
168
|
|
|
|
|
|
|
|
169
|
31
|
|
|
31
|
0
|
50
|
my ($self, $filter, $field) = @_; |
170
|
|
|
|
|
|
|
|
171
|
31
|
|
|
|
|
41
|
my $name = $field; |
172
|
|
|
|
|
|
|
|
173
|
31
|
|
|
|
|
80
|
$field = $self->fields->get($field); |
174
|
31
|
|
|
|
|
92
|
$filter = $self->filters->get($filter); |
175
|
|
|
|
|
|
|
|
176
|
31
|
50
|
33
|
|
|
470
|
return unless $field && $filter; |
177
|
|
|
|
|
|
|
|
178
|
31
|
100
|
|
|
|
86
|
if ($self->params->has($name)) { |
179
|
|
|
|
|
|
|
|
180
|
9
|
50
|
|
|
|
29
|
if (isa_coderef($filter)) { |
181
|
|
|
|
|
|
|
|
182
|
9
|
50
|
|
|
|
27
|
if (my $value = $self->params->get($name)) { |
183
|
|
|
|
|
|
|
|
184
|
9
|
50
|
|
|
|
24
|
if (isa_arrayref($value)) { |
185
|
0
|
|
|
|
|
0
|
foreach my $el (@{$value}) { |
|
0
|
|
|
|
|
0
|
|
186
|
0
|
|
|
|
|
0
|
$el = $filter->($el); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
else { |
190
|
9
|
|
|
|
|
26
|
$value = $filter->($value); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
9
|
|
|
|
|
30
|
$self->params->add($name, $value); |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
31
|
|
|
|
|
127
|
return $self; |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub apply_filters { |
207
|
|
|
|
|
|
|
|
208
|
32
|
|
|
32
|
1
|
66
|
my ($self, $state) = @_; |
209
|
|
|
|
|
|
|
|
210
|
32
|
|
50
|
|
|
98
|
$state ||= 'pre'; # state defaults to (pre) filtering |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# check for and process input filters and default values |
213
|
|
|
|
|
|
|
my $run_filter = sub { |
214
|
|
|
|
|
|
|
|
215
|
47
|
|
|
47
|
|
468
|
my ($name, $spec) = @_; |
216
|
|
|
|
|
|
|
|
217
|
47
|
50
|
|
|
|
158
|
if ($spec->filtering) { |
218
|
|
|
|
|
|
|
|
219
|
47
|
50
|
|
|
|
131
|
if ($spec->filtering eq $state) { |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# the filters directive should always be an arrayref |
222
|
47
|
100
|
|
|
|
190
|
$spec->filters([$spec->filters]) unless isa_arrayref($spec->filters); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# apply filters |
225
|
47
|
|
|
|
|
77
|
$self->apply_filter($_, $name) for @{$spec->filters}; |
|
47
|
|
|
|
|
137
|
|
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
32
|
|
|
|
|
171
|
}; |
232
|
|
|
|
|
|
|
|
233
|
32
|
|
|
|
|
113
|
$self->fields->each($run_filter); |
234
|
|
|
|
|
|
|
|
235
|
32
|
|
|
|
|
203
|
return $self; |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub apply_mixin { |
240
|
|
|
|
|
|
|
|
241
|
526
|
|
|
526
|
0
|
895
|
my ($self, $field, $mixin) = @_; |
242
|
|
|
|
|
|
|
|
243
|
526
|
100
|
66
|
|
|
2329
|
return unless $field && $mixin; |
244
|
|
|
|
|
|
|
|
245
|
470
|
|
|
|
|
1264
|
$field = $self->fields->get($field); |
246
|
|
|
|
|
|
|
|
247
|
470
|
|
33
|
|
|
1125
|
$mixin ||= $field->mixin; |
248
|
|
|
|
|
|
|
|
249
|
470
|
50
|
33
|
|
|
2014
|
return unless $mixin && $field; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
# mixin values should be in arrayref form |
252
|
|
|
|
|
|
|
|
253
|
470
|
100
|
|
|
|
1185
|
my $mixins = isa_arrayref($mixin) ? $mixin : [$mixin]; |
254
|
|
|
|
|
|
|
|
255
|
470
|
|
|
|
|
654
|
foreach my $name (@{$mixins}) { |
|
470
|
|
|
|
|
895
|
|
256
|
|
|
|
|
|
|
|
257
|
479
|
|
|
|
|
1287
|
my $mixin = $self->mixins->get($name); |
258
|
|
|
|
|
|
|
|
259
|
479
|
100
|
|
|
|
1069
|
next unless $mixin; |
260
|
|
|
|
|
|
|
|
261
|
454
|
|
|
|
|
1272
|
$self->merge_mixin($field->name, $mixin->name); |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
470
|
|
|
|
|
1050
|
return $self; |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
sub apply_mixin_field { |
270
|
|
|
|
|
|
|
|
271
|
144
|
|
|
144
|
0
|
348
|
my ($self, $field_a, $field_b) = @_; |
272
|
|
|
|
|
|
|
|
273
|
144
|
50
|
33
|
|
|
673
|
return unless $field_a && $field_b; |
274
|
|
|
|
|
|
|
|
275
|
144
|
|
|
|
|
340
|
$self->check_field($field_a); |
276
|
144
|
|
|
|
|
322
|
$self->check_field($field_b); |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# some overwriting restricted |
279
|
|
|
|
|
|
|
|
280
|
144
|
|
|
|
|
398
|
my $fields = $self->fields; |
281
|
|
|
|
|
|
|
|
282
|
144
|
|
|
|
|
427
|
$field_a = $fields->get($field_a); |
283
|
144
|
|
|
|
|
415
|
$field_b = $fields->get($field_b); |
284
|
|
|
|
|
|
|
|
285
|
144
|
50
|
33
|
|
|
726
|
return unless $field_a && $field_b; |
286
|
|
|
|
|
|
|
|
287
|
144
|
50
|
|
|
|
453
|
my $name = $field_b->name if $field_b->has('name'); |
288
|
144
|
100
|
|
|
|
529
|
my $label = $field_b->label if $field_b->has('label'); |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
# merge |
291
|
|
|
|
|
|
|
|
292
|
144
|
|
|
|
|
459
|
$self->merge_field($field_a->name, $field_b->name); |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# restore |
295
|
|
|
|
|
|
|
|
296
|
144
|
50
|
|
|
|
625
|
$field_b->name($name) if defined $name; |
297
|
144
|
100
|
|
|
|
360
|
$field_b->label($label) if defined $label; |
298
|
|
|
|
|
|
|
|
299
|
144
|
50
|
|
|
|
790
|
$self->apply_mixin($name, $field_a->mixin) if $field_a->can('mixin'); |
300
|
|
|
|
|
|
|
|
301
|
144
|
|
|
|
|
293
|
return $self; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
sub apply_validator { |
306
|
|
|
|
|
|
|
|
307
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $field_name, $field ) = @_; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# does field have a label, if not use field name (e.g. for errors, etc) |
310
|
|
|
|
|
|
|
|
311
|
0
|
0
|
|
|
|
0
|
my $name = $field->{label} ? $field->{label} : $field_name; |
312
|
0
|
|
|
|
|
0
|
my $value = $field->{value} ; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# check if required |
315
|
|
|
|
|
|
|
|
316
|
0
|
0
|
|
|
|
0
|
my $req = $field->{required} ? 1 : 0; |
317
|
|
|
|
|
|
|
|
318
|
0
|
0
|
|
|
|
0
|
if (defined $field->{'toggle'}) { |
319
|
|
|
|
|
|
|
|
320
|
0
|
0
|
|
|
|
0
|
$req = 1 if $field->{'toggle'} eq '+'; |
321
|
0
|
0
|
|
|
|
0
|
$req = 0 if $field->{'toggle'} eq '-'; |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
0
|
0
|
0
|
|
|
0
|
if ( $req && ( !defined $value || $value eq '' ) ) { |
|
|
|
0
|
|
|
|
|
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
my $error = defined $field->{error} ? |
328
|
0
|
0
|
|
|
|
0
|
$field->{error} : "$name is required"; |
329
|
|
|
|
|
|
|
|
330
|
0
|
|
|
|
|
0
|
$field->errors->add($error); |
331
|
|
|
|
|
|
|
|
332
|
0
|
|
|
|
|
0
|
return $self; # if required and fails, stop processing immediately |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
|
336
|
0
|
0
|
0
|
|
|
0
|
if ( $req || $value ) { |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# find and process all the validators |
339
|
|
|
|
|
|
|
|
340
|
0
|
|
|
|
|
0
|
foreach my $key (keys %{$field}) { |
|
0
|
|
|
|
|
0
|
|
341
|
|
|
|
|
|
|
|
342
|
0
|
|
|
|
|
0
|
my $directive = $self->directives->{$key}; |
343
|
|
|
|
|
|
|
|
344
|
0
|
0
|
|
|
|
0
|
if ($directive) { |
345
|
|
|
|
|
|
|
|
346
|
0
|
0
|
|
|
|
0
|
if ($directive->{validator}) { |
347
|
|
|
|
|
|
|
|
348
|
0
|
0
|
|
|
|
0
|
if ("CODE" eq ref $directive->{validator}) { |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# execute validator directives |
351
|
|
|
|
|
|
|
$directive->{validator}->( |
352
|
0
|
|
|
|
|
0
|
$field->{$key}, $value, $field, $self |
353
|
|
|
|
|
|
|
); |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
0
|
|
|
|
|
0
|
return $self; |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
sub check_field { |
370
|
|
|
|
|
|
|
|
371
|
1290
|
|
|
1290
|
0
|
2407
|
my ($self, $name) = @_; |
372
|
|
|
|
|
|
|
|
373
|
1290
|
|
|
|
|
3615
|
my $directives = $self->directives; |
374
|
|
|
|
|
|
|
|
375
|
1290
|
|
|
|
|
3762
|
my $field = $self->fields->get($name); |
376
|
|
|
|
|
|
|
|
377
|
1290
|
|
|
|
|
4209
|
foreach my $key ($field->keys) { |
378
|
|
|
|
|
|
|
|
379
|
11386
|
|
|
|
|
28054
|
my $directive = $directives->get($key); |
380
|
|
|
|
|
|
|
|
381
|
11386
|
100
|
|
|
|
27797
|
unless (defined $directive) { |
382
|
1
|
|
|
|
|
10
|
$self->pitch_error( sprintf |
383
|
|
|
|
|
|
|
"The %s directive supplied by the %s field is not supported", |
384
|
|
|
|
|
|
|
$key, $name |
385
|
|
|
|
|
|
|
); |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
1289
|
|
|
|
|
6541
|
return 1; |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
sub check_mixin { |
395
|
|
|
|
|
|
|
|
396
|
1905
|
|
|
1905
|
0
|
2917
|
my ($self, $name) = @_; |
397
|
|
|
|
|
|
|
|
398
|
1905
|
|
|
|
|
5182
|
my $directives = $self->directives; |
399
|
|
|
|
|
|
|
|
400
|
1905
|
|
|
|
|
5484
|
my $mixin = $self->mixins->get($name); |
401
|
|
|
|
|
|
|
|
402
|
1905
|
|
|
|
|
6019
|
foreach my $key ($mixin->keys) { |
403
|
|
|
|
|
|
|
|
404
|
8216
|
|
|
|
|
20809
|
my $directive = $directives->get($key); |
405
|
|
|
|
|
|
|
|
406
|
8216
|
50
|
|
|
|
21055
|
unless (defined $directive) { |
407
|
0
|
|
|
|
|
0
|
$self->pitch_error( sprintf |
408
|
|
|
|
|
|
|
"The %s directive supplied by the %s mixin is not supported", |
409
|
|
|
|
|
|
|
$key, $name |
410
|
|
|
|
|
|
|
); |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
1905
|
|
|
|
|
7184
|
return 1; |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
sub class { |
421
|
|
|
|
|
|
|
|
422
|
11
|
|
|
11
|
1
|
20
|
my $self = shift; |
423
|
|
|
|
|
|
|
|
424
|
11
|
|
|
|
|
28
|
my ($name, %args) = @_; |
425
|
|
|
|
|
|
|
|
426
|
11
|
50
|
|
|
|
31
|
return unless $name; |
427
|
|
|
|
|
|
|
|
428
|
11
|
|
|
|
|
16
|
my @strings; |
429
|
|
|
|
|
|
|
|
430
|
11
|
|
|
|
|
38
|
@strings = split /\//, $name; |
431
|
11
|
|
|
|
|
24
|
@strings = map { s/[^a-zA-Z0-9]+([a-zA-Z0-9])/\U$1/g; $_ } @strings; |
|
11
|
|
|
|
|
34
|
|
|
11
|
|
|
|
|
33
|
|
432
|
11
|
50
|
|
|
|
22
|
@strings = map { /\w/ ? ucfirst $_ : () } @strings; |
|
11
|
|
|
|
|
69
|
|
433
|
|
|
|
|
|
|
|
434
|
11
|
|
|
|
|
39
|
my $class = join '::', $self->{package}, @strings; |
435
|
|
|
|
|
|
|
|
436
|
11
|
50
|
|
|
|
31
|
return unless $class; |
437
|
|
|
|
|
|
|
|
438
|
11
|
|
|
|
|
35
|
my @attrs = qw( |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
ignore_failure |
441
|
|
|
|
|
|
|
ignore_intervention |
442
|
|
|
|
|
|
|
ignore_unknown |
443
|
|
|
|
|
|
|
report_failure |
444
|
|
|
|
|
|
|
report_unknown |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
); # to be copied (stash and params copied later) |
447
|
|
|
|
|
|
|
|
448
|
11
|
|
|
|
|
20
|
my %defaults = ( map { $_ => $self->$_ } @attrs ); |
|
55
|
|
|
|
|
185
|
|
449
|
|
|
|
|
|
|
|
450
|
11
|
|
|
|
|
46
|
$defaults{'stash'} = $self->stashed; # copy stash |
451
|
11
|
|
|
|
|
31
|
$defaults{'params'} = $self->get_params; # copy params |
452
|
|
|
|
|
|
|
|
453
|
11
|
|
|
|
|
19
|
my %settings = %{ merge \%args, \%defaults }; |
|
11
|
|
|
|
|
40
|
|
454
|
|
|
|
|
|
|
|
455
|
11
|
|
|
|
|
1595
|
use_module $class; |
456
|
|
|
|
|
|
|
|
457
|
11
|
|
|
|
|
303
|
for (keys %settings) { |
458
|
|
|
|
|
|
|
|
459
|
77
|
50
|
|
|
|
344
|
delete $settings{$_} unless $class->can($_); |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
11
|
50
|
|
|
|
61
|
return unless $class->can('new'); |
464
|
11
|
50
|
|
|
|
35
|
return unless $self->registry->has($class); # isa validation class |
465
|
|
|
|
|
|
|
|
466
|
11
|
|
|
|
|
59
|
my $child = $class->new(%settings); |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
{ |
469
|
|
|
|
|
|
|
|
470
|
11
|
0
|
|
|
|
25
|
my $proto_method = |
|
11
|
50
|
|
|
|
57
|
|
471
|
|
|
|
|
|
|
$child->can('proto') ? 'proto' : |
472
|
|
|
|
|
|
|
$child->can('prototype') ? 'prototype' : undef |
473
|
|
|
|
|
|
|
; |
474
|
|
|
|
|
|
|
|
475
|
11
|
50
|
|
|
|
31
|
if ($proto_method) { |
476
|
|
|
|
|
|
|
|
477
|
11
|
|
|
|
|
44
|
my $proto = $child->$proto_method; |
478
|
|
|
|
|
|
|
|
479
|
11
|
50
|
|
|
|
38
|
if (defined $settings{'params'}) { |
480
|
|
|
|
|
|
|
|
481
|
11
|
|
|
|
|
32
|
foreach my $key ($proto->params->keys) { |
482
|
|
|
|
|
|
|
|
483
|
13
|
100
|
|
|
|
179
|
if ($key =~ /^$name\.(.*)/) { |
484
|
|
|
|
|
|
|
|
485
|
2
|
50
|
|
|
|
8
|
if ($proto->fields->has($1)) { |
486
|
|
|
|
|
|
|
|
487
|
2
|
|
|
|
|
4
|
push @{$proto->fields->{$1}->{alias}}, $key; |
|
2
|
|
|
|
|
7
|
|
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
11
|
|
|
|
|
107
|
return $child; |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
sub clear_queue { |
507
|
|
|
|
|
|
|
|
508
|
19
|
|
|
19
|
1
|
39
|
my $self = shift; |
509
|
|
|
|
|
|
|
|
510
|
19
|
|
|
|
|
82
|
my @names = $self->queued->list; |
511
|
|
|
|
|
|
|
|
512
|
19
|
|
|
|
|
89
|
for (my $i = 0; $i < @names; $i++) { |
513
|
|
|
|
|
|
|
|
514
|
120
|
|
|
|
|
358
|
$names[$i] =~ s/^[\-\+]{1}//; |
515
|
120
|
|
|
|
|
325
|
$_[$i] = $self->params->get($names[$i]); |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
19
|
|
|
|
|
70
|
$self->queued->clear; |
520
|
|
|
|
|
|
|
|
521
|
19
|
|
|
|
|
79
|
return @_; |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
sub clone_field { |
527
|
|
|
|
|
|
|
|
528
|
122
|
|
|
122
|
1
|
234
|
my ($self, $field, $new_field, $directives) = @_; |
529
|
|
|
|
|
|
|
|
530
|
122
|
|
100
|
|
|
338
|
$directives ||= {}; |
531
|
|
|
|
|
|
|
|
532
|
122
|
50
|
|
|
|
395
|
$directives->{name} = $new_field unless $directives->{name}; |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# build a new field from an existing one during runtime |
535
|
|
|
|
|
|
|
|
536
|
122
|
|
|
|
|
340
|
$self->fields->add( |
537
|
|
|
|
|
|
|
$new_field => Validation::Class::Field->new($directives) |
538
|
|
|
|
|
|
|
); |
539
|
|
|
|
|
|
|
|
540
|
122
|
|
|
|
|
676
|
$self->apply_mixin_field($new_field, $field); |
541
|
|
|
|
|
|
|
|
542
|
122
|
|
|
|
|
207
|
return $self; |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
sub does { |
548
|
|
|
|
|
|
|
|
549
|
5
|
|
|
5
|
1
|
13
|
my ($self, $role) = @_; |
550
|
|
|
|
|
|
|
|
551
|
5
|
|
|
|
|
20
|
my $roles = $self->settings->get('roles'); |
552
|
|
|
|
|
|
|
|
553
|
5
|
100
|
|
8
|
|
33
|
return $roles ? (firstval { $_ eq $role } @{$roles}) ? 1 : 0 : 0; |
|
8
|
50
|
|
|
|
46
|
|
|
5
|
|
|
|
|
23
|
|
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
sub error_count { |
559
|
|
|
|
|
|
|
|
560
|
450
|
|
|
450
|
1
|
769
|
my ($self) = @_; |
561
|
|
|
|
|
|
|
|
562
|
450
|
|
|
|
|
1955
|
my $i = $self->errors->count; |
563
|
|
|
|
|
|
|
|
564
|
450
|
|
|
|
|
1621
|
$i += $_->errors->count for $self->fields->values; |
565
|
|
|
|
|
|
|
|
566
|
450
|
|
|
|
|
3566
|
return $i; |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
sub error_fields { |
572
|
|
|
|
|
|
|
|
573
|
0
|
|
|
0
|
1
|
0
|
my ($self, @fields) = @_; |
574
|
|
|
|
|
|
|
|
575
|
0
|
|
|
|
|
0
|
my $failed = {}; |
576
|
|
|
|
|
|
|
|
577
|
0
|
0
|
|
|
|
0
|
@fields = $self->fields->keys unless @fields; |
578
|
|
|
|
|
|
|
|
579
|
0
|
|
|
|
|
0
|
foreach my $name (@fields) { |
580
|
|
|
|
|
|
|
|
581
|
0
|
|
|
|
|
0
|
my $field = $self->fields->{$name}; |
582
|
|
|
|
|
|
|
|
583
|
0
|
0
|
|
|
|
0
|
if ($field->{errors}->count) { |
584
|
|
|
|
|
|
|
|
585
|
0
|
|
|
|
|
0
|
$failed->{$name} = [$field->{errors}->list]; |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
|
591
|
0
|
|
|
|
|
0
|
return $failed; |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
sub errors_to_string { |
597
|
|
|
|
|
|
|
|
598
|
36
|
|
|
36
|
1
|
86
|
my $self = shift; |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
# combine class and field errors |
601
|
|
|
|
|
|
|
|
602
|
36
|
|
|
|
|
205
|
my $errors = Validation::Class::Errors->new([]); |
603
|
|
|
|
|
|
|
|
604
|
36
|
|
|
|
|
168
|
$errors->add($self->errors->list); |
605
|
|
|
|
|
|
|
|
606
|
36
|
|
|
|
|
177
|
$errors->add($_->errors->list) for ($self->fields->values); |
607
|
|
|
|
|
|
|
|
608
|
36
|
|
|
|
|
209
|
return $errors->to_string(@_); |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
sub flatten_params { |
613
|
|
|
|
|
|
|
|
614
|
0
|
|
|
0
|
0
|
0
|
my ($self, $hash) = @_; |
615
|
|
|
|
|
|
|
|
616
|
0
|
0
|
|
|
|
0
|
if ($hash) { |
617
|
|
|
|
|
|
|
|
618
|
0
|
|
|
|
|
0
|
$hash = Hash::Flatten::flatten($hash); |
619
|
|
|
|
|
|
|
|
620
|
0
|
|
|
|
|
0
|
$self->params->add($hash); |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
|
624
|
0
|
|
0
|
|
|
0
|
return $self->params->flatten->hash || {}; |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
sub get_errors { |
630
|
|
|
|
|
|
|
|
631
|
19
|
|
|
19
|
1
|
46
|
my ($self, @criteria) = @_; |
632
|
|
|
|
|
|
|
|
633
|
19
|
|
|
|
|
88
|
my $errors = Validation::Class::Errors->new([]); # combined errors |
634
|
|
|
|
|
|
|
|
635
|
19
|
50
|
|
|
|
69
|
if (!@criteria) { |
|
|
0
|
|
|
|
|
|
636
|
|
|
|
|
|
|
|
637
|
19
|
|
|
|
|
76
|
$errors->add($self->errors->list); |
638
|
|
|
|
|
|
|
|
639
|
19
|
|
|
|
|
74
|
$errors->add($_->errors->list) for ($self->fields->values); |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
elsif (isa_regexp($criteria[0])) { |
644
|
|
|
|
|
|
|
|
645
|
0
|
|
|
|
|
0
|
my $query = $criteria[0]; |
646
|
|
|
|
|
|
|
|
647
|
0
|
|
|
|
|
0
|
$errors->add($self->errors->grep($query)->list); |
648
|
0
|
|
|
|
|
0
|
$errors->add($_->errors->grep($query)->list) for $self->fields->values; |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
else { |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
$errors->add($_->errors->list) |
655
|
0
|
|
|
|
|
0
|
for map {$self->fields->get($_)} @criteria; |
|
0
|
|
|
|
|
0
|
|
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
|
659
|
19
|
|
|
|
|
125
|
return ($errors->list); |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
sub get_fields { |
665
|
|
|
|
|
|
|
|
666
|
0
|
|
|
0
|
1
|
0
|
my ($self, @fields) = @_; |
667
|
|
|
|
|
|
|
|
668
|
0
|
0
|
|
|
|
0
|
return () unless @fields; |
669
|
|
|
|
|
|
|
|
670
|
0
|
0
|
|
|
|
0
|
return (map { $self->fields->get($_) || undef } @fields); |
|
0
|
|
|
|
|
0
|
|
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
sub get_hash { |
676
|
|
|
|
|
|
|
|
677
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
678
|
|
|
|
|
|
|
|
679
|
0
|
|
|
|
|
0
|
return { map { $_ => $self->get_values($_) } $self->fields->keys }; |
|
0
|
|
|
|
|
0
|
|
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
sub get_params { |
685
|
|
|
|
|
|
|
|
686
|
11
|
|
|
11
|
1
|
24
|
my ($self, @params) = @_; |
687
|
|
|
|
|
|
|
|
688
|
11
|
|
50
|
|
|
31
|
my $params = $self->params->hash || {}; |
689
|
|
|
|
|
|
|
|
690
|
11
|
50
|
|
|
|
36
|
if (@params) { |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
return @params ? |
693
|
0
|
0
|
|
|
|
0
|
(map { defined $params->{$_} ? $params->{$_} : undef } @params) : |
|
0
|
0
|
|
|
|
0
|
|
694
|
|
|
|
|
|
|
() |
695
|
|
|
|
|
|
|
; |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
else { |
700
|
|
|
|
|
|
|
|
701
|
11
|
|
|
|
|
31
|
return $params; |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
sub get_values { |
709
|
|
|
|
|
|
|
|
710
|
0
|
|
|
0
|
1
|
0
|
my ($self, @fields) = @_; |
711
|
|
|
|
|
|
|
|
712
|
0
|
0
|
|
|
|
0
|
return () unless @fields; |
713
|
|
|
|
|
|
|
return ( |
714
|
|
|
|
|
|
|
map { |
715
|
0
|
|
|
|
|
0
|
my $field = $self->fields->get($_); |
|
0
|
|
|
|
|
0
|
|
716
|
0
|
|
|
|
|
0
|
my $param = $self->params->get($_); |
717
|
0
|
0
|
0
|
|
|
0
|
$field->readonly ? |
|
|
|
0
|
|
|
|
|
718
|
|
|
|
|
|
|
$field->default || undef : |
719
|
|
|
|
|
|
|
$field->value || $param |
720
|
|
|
|
|
|
|
; |
721
|
|
|
|
|
|
|
} @fields |
722
|
|
|
|
|
|
|
); |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
sub is_valid { |
728
|
|
|
|
|
|
|
|
729
|
400
|
|
|
400
|
1
|
745
|
my ($self) = @_; |
730
|
|
|
|
|
|
|
|
731
|
400
|
100
|
|
|
|
1359
|
return $self->error_count ? 0 : 1; |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
sub merge_field { |
736
|
|
|
|
|
|
|
|
737
|
144
|
|
|
144
|
0
|
258
|
my ($self, $field_a, $field_b) = @_; |
738
|
|
|
|
|
|
|
|
739
|
144
|
50
|
33
|
|
|
652
|
return unless $field_a && $field_b; |
740
|
|
|
|
|
|
|
|
741
|
144
|
|
|
|
|
390
|
my $directives = $self->directives; |
742
|
|
|
|
|
|
|
|
743
|
144
|
|
|
|
|
428
|
$field_a = $self->fields->get($field_a); |
744
|
144
|
|
|
|
|
404
|
$field_b = $self->fields->get($field_b); |
745
|
|
|
|
|
|
|
|
746
|
144
|
50
|
33
|
|
|
687
|
return unless $field_a && $field_b; |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
# keep in mind that in this case we're using field_b as a mixin |
749
|
|
|
|
|
|
|
|
750
|
144
|
|
|
|
|
483
|
foreach my $pair ($field_b->pairs) { |
751
|
|
|
|
|
|
|
|
752
|
1295
|
|
|
|
|
1593
|
my ($key, $value) = @{$pair}{'key', 'value'}; |
|
1295
|
|
|
|
|
2824
|
|
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
# skip unless the directive is mixin compatible |
755
|
|
|
|
|
|
|
|
756
|
1295
|
100
|
|
|
|
3770
|
next unless $directives->get($key)->mixin; |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
# do not override existing keys but multi values append |
759
|
|
|
|
|
|
|
|
760
|
850
|
100
|
|
|
|
2357
|
if ($field_a->has($key)) { |
761
|
|
|
|
|
|
|
|
762
|
269
|
100
|
|
|
|
743
|
next unless $directives->get($key)->multi; |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
|
766
|
628
|
50
|
|
|
|
1900
|
if ($directives->get($key)->field) { |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
# can the directive have multiple values, merge array |
769
|
|
|
|
|
|
|
|
770
|
628
|
100
|
|
|
|
1616
|
if ($directives->get($key)->multi) { |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
# if field has existing array value, merge unique |
773
|
|
|
|
|
|
|
|
774
|
271
|
100
|
|
|
|
992
|
if (isa_arrayref($field_a->{$key})) { |
775
|
|
|
|
|
|
|
|
776
|
21
|
50
|
|
|
|
69
|
my @values = isa_arrayref($value) ? @{$value} : ($value); |
|
21
|
|
|
|
|
57
|
|
777
|
|
|
|
|
|
|
|
778
|
21
|
|
|
|
|
44
|
push @values, @{$field_a->{$key}}; |
|
21
|
|
|
|
|
49
|
|
779
|
|
|
|
|
|
|
|
780
|
21
|
|
|
|
|
99
|
@values = uniq @values; |
781
|
|
|
|
|
|
|
|
782
|
21
|
|
|
|
|
96
|
$field_a->{$key} = [@values]; |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
} |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# simple copy |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
else { |
789
|
|
|
|
|
|
|
|
790
|
250
|
100
|
|
|
|
605
|
$field_a->{$key} = isa_arrayref($value) ? $value : [$value]; |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
} |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
# simple copy |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
else { |
799
|
|
|
|
|
|
|
|
800
|
357
|
|
|
|
|
1037
|
$field_a->{$key} = $value; |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
} |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
|
|
808
|
144
|
|
|
|
|
735
|
return $self; |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
} |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
sub merge_mixin { |
813
|
|
|
|
|
|
|
|
814
|
454
|
|
|
454
|
0
|
741
|
my ($self, $field, $mixin) = @_; |
815
|
|
|
|
|
|
|
|
816
|
454
|
50
|
33
|
|
|
1913
|
return unless $field && $mixin; |
817
|
|
|
|
|
|
|
|
818
|
454
|
|
|
|
|
1169
|
my $directives = $self->directives; |
819
|
|
|
|
|
|
|
|
820
|
454
|
|
|
|
|
1181
|
$field = $self->fields->get($field); |
821
|
454
|
|
|
|
|
1252
|
$mixin = $self->mixins->get($mixin); |
822
|
|
|
|
|
|
|
|
823
|
454
|
|
|
|
|
1675
|
foreach my $pair ($mixin->pairs) { |
824
|
|
|
|
|
|
|
|
825
|
1824
|
|
|
|
|
2298
|
my ($key, $value) = @{$pair}{'key', 'value'}; |
|
1824
|
|
|
|
|
3942
|
|
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
# do not override existing keys but multi values append |
828
|
|
|
|
|
|
|
|
829
|
1824
|
100
|
|
|
|
5302
|
if ($field->has($key)) { |
830
|
|
|
|
|
|
|
|
831
|
1648
|
100
|
|
|
|
4257
|
next unless $directives->get($key)->multi; |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
|
835
|
532
|
50
|
|
|
|
1685
|
if ($directives->get($key)->field) { |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
# can the directive have multiple values, merge array |
838
|
|
|
|
|
|
|
|
839
|
532
|
100
|
|
|
|
1394
|
if ($directives->get($key)->multi) { |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
# if field has existing array value, merge unique |
842
|
|
|
|
|
|
|
|
843
|
410
|
100
|
|
|
|
1191
|
if (isa_arrayref($field->{$key})) { |
844
|
|
|
|
|
|
|
|
845
|
354
|
100
|
|
|
|
826
|
my @values = isa_arrayref($value) ? @{$value} : ($value); |
|
330
|
|
|
|
|
742
|
|
846
|
|
|
|
|
|
|
|
847
|
354
|
|
|
|
|
529
|
push @values, @{$field->{$key}}; |
|
354
|
|
|
|
|
850
|
|
848
|
|
|
|
|
|
|
|
849
|
354
|
|
|
|
|
1776
|
@values = uniq @values; |
850
|
|
|
|
|
|
|
|
851
|
354
|
|
|
|
|
1646
|
$field->{$key} = [@values]; |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
# merge copy |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
else { |
858
|
|
|
|
|
|
|
|
859
|
56
|
100
|
|
|
|
157
|
my @values = isa_arrayref($value) ? @{$value} : ($value); |
|
43
|
|
|
|
|
119
|
|
860
|
|
|
|
|
|
|
|
861
|
56
|
100
|
|
|
|
174
|
push @values, $field->{$key} if $field->{$key}; |
862
|
|
|
|
|
|
|
|
863
|
56
|
|
|
|
|
343
|
@values = uniq @values; |
864
|
|
|
|
|
|
|
|
865
|
56
|
|
|
|
|
302
|
$field->{$key} = [@values]; |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
} |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
# simple copy |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
else { |
874
|
|
|
|
|
|
|
|
875
|
122
|
|
|
|
|
388
|
$field->{$key} = $value; |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
454
|
|
|
|
|
1882
|
return $field; |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
sub normalize { |
889
|
|
|
|
|
|
|
|
890
|
610
|
|
|
610
|
1
|
1214
|
my ($self, $context) = @_; |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
# we need context |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
confess |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
"Context object ($self->{package} class instance) required ". |
897
|
610
|
50
|
|
|
|
2066
|
"to perform validation" unless $self->{package} eq ref $context |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
; |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
# stash the current context object |
902
|
610
|
|
|
|
|
1698
|
$self->stash->{'normalization.context'} = $context; |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
# resets |
905
|
|
|
|
|
|
|
|
906
|
610
|
|
|
|
|
2175
|
$self->validated(0); |
907
|
|
|
|
|
|
|
|
908
|
610
|
|
|
|
|
1870
|
$self->reset_fields; |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
# validate mixin directives |
911
|
|
|
|
|
|
|
|
912
|
610
|
|
|
|
|
2224
|
foreach my $key ($self->mixins->keys) { |
913
|
|
|
|
|
|
|
|
914
|
1905
|
|
|
|
|
4567
|
$self->check_mixin($key); |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
} |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
# check for and process a mixin directive |
919
|
|
|
|
|
|
|
|
920
|
610
|
|
|
|
|
2883
|
foreach my $key ($self->fields->keys) { |
921
|
|
|
|
|
|
|
|
922
|
1002
|
|
|
|
|
2979
|
my $field = $self->fields->get($key); |
923
|
|
|
|
|
|
|
|
924
|
1002
|
50
|
|
|
|
2729
|
next unless $field; |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
$self->apply_mixin($key, $field->{mixin}) |
927
|
1002
|
100
|
33
|
|
|
7213
|
if $field->can('mixin') && $field->{mixin}; |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
} |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
# check for and process a mixin_field directive |
932
|
|
|
|
|
|
|
|
933
|
610
|
|
|
|
|
2694
|
foreach my $key ($self->fields->keys) { |
934
|
|
|
|
|
|
|
|
935
|
1002
|
|
|
|
|
2926
|
my $field = $self->fields->get($key); |
936
|
|
|
|
|
|
|
|
937
|
1002
|
50
|
|
|
|
2539
|
next unless $field; |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
$self->apply_mixin_field($key, $field->{mixin_field}) |
940
|
|
|
|
|
|
|
if $field->can('mixin_field') && $field->{mixin_field} |
941
|
1002
|
100
|
33
|
|
|
6335
|
; |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
# execute normalization events |
946
|
|
|
|
|
|
|
|
947
|
610
|
|
|
|
|
2615
|
foreach my $key ($self->fields->keys) { |
948
|
|
|
|
|
|
|
|
949
|
1002
|
|
|
|
|
2659
|
$self->trigger_event('on_normalize', $key); |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
} |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
# alias checking, ... for duplicate aliases, etc |
954
|
|
|
|
|
|
|
|
955
|
610
|
|
|
|
|
1877
|
my $mapper = {}; |
956
|
610
|
|
|
|
|
2174
|
my @fields = $self->fields->keys; |
957
|
|
|
|
|
|
|
|
958
|
610
|
|
|
|
|
1996
|
foreach my $name (@fields) { |
959
|
|
|
|
|
|
|
|
960
|
1002
|
|
|
|
|
2995
|
my $field = $self->fields->get($name); |
961
|
1002
|
100
|
|
|
|
3415
|
my $label = $field->{label} ? $field->{label} : "The field $name"; |
962
|
|
|
|
|
|
|
|
963
|
1002
|
100
|
|
|
|
3270
|
if (defined $field->{alias}) { |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
my $aliases = "ARRAY" eq ref $field->{alias} |
966
|
16
|
50
|
|
|
|
64
|
? $field->{alias} : [$field->{alias}]; |
967
|
|
|
|
|
|
|
|
968
|
16
|
|
|
|
|
41
|
foreach my $alias (@{$aliases}) { |
|
16
|
|
|
|
|
38
|
|
969
|
|
|
|
|
|
|
|
970
|
16
|
50
|
|
|
|
54
|
if ($mapper->{$alias}) { |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
my $alt_field = |
973
|
0
|
|
|
|
|
0
|
$self->fields->get($mapper->{$alias}) |
974
|
|
|
|
|
|
|
; |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
my $alt_label = $alt_field->{label} ? |
977
|
0
|
0
|
|
|
|
0
|
$alt_field->{label} : "the field $mapper->{$alias}" |
978
|
|
|
|
|
|
|
; |
979
|
|
|
|
|
|
|
|
980
|
0
|
|
|
|
|
0
|
my $error = |
981
|
|
|
|
|
|
|
qq($label contains the alias $alias which is |
982
|
|
|
|
|
|
|
also an alias on $alt_label) |
983
|
|
|
|
|
|
|
; |
984
|
|
|
|
|
|
|
|
985
|
0
|
|
|
|
|
0
|
$self->throw_error($error); |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
|
989
|
16
|
50
|
|
|
|
55
|
if ($self->fields->has($alias)) { |
990
|
|
|
|
|
|
|
|
991
|
0
|
|
|
|
|
0
|
my $error = |
992
|
|
|
|
|
|
|
qq($label contains the alias $alias which is |
993
|
|
|
|
|
|
|
the name of an existing field) |
994
|
|
|
|
|
|
|
; |
995
|
|
|
|
|
|
|
|
996
|
0
|
|
|
|
|
0
|
$self->throw_error($error); |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
|
1000
|
16
|
|
|
|
|
74
|
$mapper->{$alias} = $name; |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
} |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
} |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
# final checkpoint, validate field directives |
1009
|
|
|
|
|
|
|
|
1010
|
610
|
|
|
|
|
1941
|
foreach my $key ($self->fields->keys) { |
1011
|
|
|
|
|
|
|
|
1012
|
1002
|
|
|
|
|
2912
|
$self->check_field($key); |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
} |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
# delete the stashed context object |
1017
|
609
|
|
|
|
|
2287
|
delete $self->stash->{'normalization.context'}; |
1018
|
|
|
|
|
|
|
|
1019
|
609
|
|
|
|
|
1715
|
return $self; |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
} |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
sub param { |
1025
|
|
|
|
|
|
|
|
1026
|
10
|
|
|
10
|
1
|
23
|
my ($self, $name, $value) = @_; |
1027
|
|
|
|
|
|
|
|
1028
|
10
|
100
|
|
|
|
29
|
if (defined $value) { |
1029
|
8
|
|
|
|
|
28
|
$self->params->add($name, $value); |
1030
|
8
|
|
|
|
|
29
|
return $value; |
1031
|
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
|
else { |
1033
|
2
|
50
|
|
|
|
8
|
return unless $self->params->has($name); |
1034
|
2
|
|
|
|
|
9
|
return $self->params->get($name); |
1035
|
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
} |
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
sub pitch_error { |
1040
|
|
|
|
|
|
|
|
1041
|
9
|
|
|
9
|
0
|
20
|
my ($self, $error_message) = @_; |
1042
|
|
|
|
|
|
|
|
1043
|
9
|
|
|
|
|
25
|
$error_message =~ s/\n/ /g; |
1044
|
9
|
|
|
|
|
90
|
$error_message =~ s/\s+/ /g; |
1045
|
|
|
|
|
|
|
|
1046
|
9
|
100
|
|
|
|
41
|
if ($self->ignore_unknown) { |
1047
|
|
|
|
|
|
|
|
1048
|
7
|
100
|
|
|
|
30
|
if ($self->report_unknown) { |
1049
|
2
|
|
|
|
|
9
|
$self->errors->add($error_message); |
1050
|
|
|
|
|
|
|
} |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
} |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
else { |
1055
|
2
|
|
|
|
|
9
|
$self->throw_error($error_message); |
1056
|
|
|
|
|
|
|
} |
1057
|
|
|
|
|
|
|
|
1058
|
7
|
|
|
|
|
23
|
return $self; |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
} |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
sub plugin { |
1064
|
|
|
|
|
|
|
|
1065
|
0
|
|
|
0
|
1
|
0
|
my ($self, $name) = @_; |
1066
|
|
|
|
|
|
|
|
1067
|
0
|
0
|
|
|
|
0
|
return unless $name; |
1068
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
# transform what looks like a shortname |
1070
|
|
|
|
|
|
|
|
1071
|
0
|
|
|
|
|
0
|
my @strings; |
1072
|
|
|
|
|
|
|
|
1073
|
0
|
|
|
|
|
0
|
@strings = split /\//, $name; |
1074
|
0
|
|
|
|
|
0
|
@strings = map { s/[^a-zA-Z0-9]+([a-zA-Z0-9])/\U$1/g; $_ } @strings; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1075
|
0
|
0
|
|
|
|
0
|
@strings = map { /\w/ ? ucfirst $_ : () } @strings; |
|
0
|
|
|
|
|
0
|
|
1076
|
|
|
|
|
|
|
|
1077
|
0
|
|
|
|
|
0
|
my $class = join '::', 'Validation::Class::Plugin', @strings; |
1078
|
|
|
|
|
|
|
|
1079
|
0
|
|
|
|
|
0
|
eval { use_module $class }; |
|
0
|
|
|
|
|
0
|
|
1080
|
|
|
|
|
|
|
|
1081
|
0
|
|
|
|
|
0
|
return $class->new($self); |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
} |
1084
|
|
|
|
|
|
|
|
1085
|
|
|
|
|
|
|
sub proxy_methods { |
1086
|
|
|
|
|
|
|
|
1087
|
324
|
|
|
324
|
0
|
2955
|
return qw{ |
1088
|
|
|
|
|
|
|
|
1089
|
|
|
|
|
|
|
class |
1090
|
|
|
|
|
|
|
clear_queue |
1091
|
|
|
|
|
|
|
error |
1092
|
|
|
|
|
|
|
error_count |
1093
|
|
|
|
|
|
|
error_fields |
1094
|
|
|
|
|
|
|
errors |
1095
|
|
|
|
|
|
|
errors_to_string |
1096
|
|
|
|
|
|
|
get_errors |
1097
|
|
|
|
|
|
|
get_fields |
1098
|
|
|
|
|
|
|
get_hash |
1099
|
|
|
|
|
|
|
get_params |
1100
|
|
|
|
|
|
|
get_values |
1101
|
|
|
|
|
|
|
fields |
1102
|
|
|
|
|
|
|
filtering |
1103
|
|
|
|
|
|
|
ignore_failure |
1104
|
|
|
|
|
|
|
ignore_intervention |
1105
|
|
|
|
|
|
|
ignore_unknown |
1106
|
|
|
|
|
|
|
is_valid |
1107
|
|
|
|
|
|
|
param |
1108
|
|
|
|
|
|
|
params |
1109
|
|
|
|
|
|
|
plugin |
1110
|
|
|
|
|
|
|
queue |
1111
|
|
|
|
|
|
|
report_failure |
1112
|
|
|
|
|
|
|
report_unknown |
1113
|
|
|
|
|
|
|
reset_errors |
1114
|
|
|
|
|
|
|
reset_fields |
1115
|
|
|
|
|
|
|
reset_params |
1116
|
|
|
|
|
|
|
set_errors |
1117
|
|
|
|
|
|
|
set_fields |
1118
|
|
|
|
|
|
|
set_params |
1119
|
|
|
|
|
|
|
stash |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
} |
1122
|
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
|
} |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
sub proxy_methods_wrapped { |
1126
|
|
|
|
|
|
|
|
1127
|
159
|
|
|
159
|
0
|
865
|
return qw{ |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
validate |
1130
|
|
|
|
|
|
|
validates |
1131
|
|
|
|
|
|
|
validate_document |
1132
|
|
|
|
|
|
|
document_validates |
1133
|
|
|
|
|
|
|
validate_method |
1134
|
|
|
|
|
|
|
method_validates |
1135
|
|
|
|
|
|
|
validate_profile |
1136
|
|
|
|
|
|
|
profile_validates |
1137
|
|
|
|
|
|
|
|
1138
|
|
|
|
|
|
|
} |
1139
|
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
|
} |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
|
1143
|
|
|
|
|
|
|
sub queue { |
1144
|
|
|
|
|
|
|
|
1145
|
144
|
|
|
144
|
1
|
212
|
my $self = shift; |
1146
|
|
|
|
|
|
|
|
1147
|
144
|
|
|
|
|
181
|
push @{$self->queued}, @_; |
|
144
|
|
|
|
|
766
|
|
1148
|
|
|
|
|
|
|
|
1149
|
144
|
|
|
|
|
256
|
return $self; |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
} |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
sub register_attribute { |
1154
|
|
|
|
|
|
|
|
1155
|
14
|
|
|
14
|
0
|
32
|
my ($self, $attribute, $default) = @_; |
1156
|
|
|
|
|
|
|
|
1157
|
14
|
|
|
|
|
24
|
my $settings; |
1158
|
|
|
|
|
|
|
|
1159
|
108
|
|
|
108
|
|
846
|
no strict 'refs'; |
|
108
|
|
|
|
|
277
|
|
|
108
|
|
|
|
|
4107
|
|
1160
|
108
|
|
|
108
|
|
553
|
no warnings 'redefine'; |
|
108
|
|
|
|
|
240
|
|
|
108
|
|
|
|
|
161038
|
|
1161
|
|
|
|
|
|
|
|
1162
|
14
|
50
|
|
|
|
76
|
confess "Error creating accessor '$attribute', name has invalid characters" |
1163
|
|
|
|
|
|
|
unless $attribute =~ /^[a-zA-Z_]\w*$/; |
1164
|
|
|
|
|
|
|
|
1165
|
14
|
50
|
66
|
|
|
60
|
confess "Error creating accessor, default must be a coderef or constant" |
1166
|
|
|
|
|
|
|
if ref $default && ref $default ne 'CODE'; |
1167
|
|
|
|
|
|
|
|
1168
|
14
|
50
|
|
|
|
56
|
$default = ($settings = $default)->{default} if isa_hashref($default); |
1169
|
|
|
|
|
|
|
|
1170
|
14
|
|
|
|
|
24
|
my $check; |
1171
|
|
|
|
|
|
|
my $code; |
1172
|
|
|
|
|
|
|
|
1173
|
14
|
50
|
|
|
|
84
|
if ($settings) { |
1174
|
0
|
0
|
|
|
|
0
|
if (defined $settings->{isa}) { |
1175
|
|
|
|
|
|
|
$settings->{isa} = 'rw' |
1176
|
0
|
0
|
0
|
|
|
0
|
unless defined $settings->{isa} and $settings->{isa} eq 'ro' |
1177
|
|
|
|
|
|
|
; |
1178
|
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
|
1181
|
14
|
100
|
|
|
|
37
|
if (defined $default) { |
1182
|
|
|
|
|
|
|
|
1183
|
|
|
|
|
|
|
$code = sub { |
1184
|
|
|
|
|
|
|
|
1185
|
31
|
100
|
|
31
|
|
1799
|
if (@_ == 1) { |
1186
|
20
|
100
|
|
|
|
119
|
return $_[0]->{$attribute} if exists $_[0]->{$attribute}; |
1187
|
7
|
100
|
|
|
|
44
|
return $_[0]->{$attribute} = ref $default eq 'CODE' ? |
1188
|
|
|
|
|
|
|
$default->($_[0]) : $default; |
1189
|
|
|
|
|
|
|
} |
1190
|
11
|
|
|
|
|
39
|
$_[0]->{$attribute} = $_[1]; $_[0]; |
|
11
|
|
|
|
|
148
|
|
1191
|
|
|
|
|
|
|
|
1192
|
10
|
|
|
|
|
41
|
}; |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
} |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
else { |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
$code = sub { |
1199
|
|
|
|
|
|
|
|
1200
|
6
|
100
|
|
6
|
|
1086
|
return $_[0]->{$attribute} if @_ == 1; |
1201
|
2
|
|
|
|
|
5
|
$_[0]->{$attribute} = $_[1]; $_[0]; |
|
2
|
|
|
|
|
9
|
|
1202
|
|
|
|
|
|
|
|
1203
|
4
|
|
|
|
|
19
|
}; |
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
} |
1206
|
|
|
|
|
|
|
|
1207
|
14
|
|
|
|
|
53
|
$self->set_method($attribute, $code); |
1208
|
14
|
|
|
|
|
64
|
$self->configuration->attributes->add($attribute, $code); |
1209
|
|
|
|
|
|
|
|
1210
|
14
|
|
|
|
|
52
|
return $self; |
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
} |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
sub register_builder { |
1215
|
|
|
|
|
|
|
|
1216
|
4
|
|
|
4
|
0
|
11
|
my ($self, $code) = @_; |
1217
|
|
|
|
|
|
|
|
1218
|
4
|
|
|
|
|
15
|
$self->configuration->builders->add($code); |
1219
|
|
|
|
|
|
|
|
1220
|
4
|
|
|
|
|
11
|
return $self; |
1221
|
|
|
|
|
|
|
|
1222
|
|
|
|
|
|
|
} |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
sub register_directive { |
1225
|
|
|
|
|
|
|
|
1226
|
3
|
|
|
3
|
0
|
6
|
my ($self, $name, $code) = @_; |
1227
|
|
|
|
|
|
|
|
1228
|
3
|
|
|
|
|
22
|
my $directive = Validation::Class::Directive->new( |
1229
|
|
|
|
|
|
|
name => $name, |
1230
|
|
|
|
|
|
|
validator => $code |
1231
|
|
|
|
|
|
|
); |
1232
|
|
|
|
|
|
|
|
1233
|
3
|
|
|
|
|
14
|
$self->configuration->directives->add($name, $directive); |
1234
|
|
|
|
|
|
|
|
1235
|
3
|
|
|
|
|
10
|
return $self; |
1236
|
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
|
} |
1238
|
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
|
sub register_document { |
1240
|
|
|
|
|
|
|
|
1241
|
12
|
|
|
12
|
0
|
24
|
my ($self, $name, $data) = @_; |
1242
|
|
|
|
|
|
|
|
1243
|
12
|
|
|
|
|
50
|
$self->configuration->documents->add($name, $data); |
1244
|
|
|
|
|
|
|
|
1245
|
12
|
|
|
|
|
33
|
return $self; |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
} |
1248
|
|
|
|
|
|
|
|
1249
|
|
|
|
|
|
|
sub register_ensure { |
1250
|
|
|
|
|
|
|
|
1251
|
2
|
|
|
2
|
0
|
6
|
my ($self, $name, $data) = @_; |
1252
|
|
|
|
|
|
|
|
1253
|
2
|
|
|
|
|
6
|
my $package = $self->{package}; |
1254
|
2
|
|
|
|
|
10
|
my $code = $package->can($name); |
1255
|
|
|
|
|
|
|
|
1256
|
2
|
50
|
|
|
|
7
|
confess |
1257
|
|
|
|
|
|
|
"Error creating pre/post condition(s) ". |
1258
|
|
|
|
|
|
|
"around method $name on $package: method does not exist" |
1259
|
|
|
|
|
|
|
unless $code |
1260
|
|
|
|
|
|
|
; |
1261
|
|
|
|
|
|
|
|
1262
|
2
|
|
|
|
|
5
|
$data->{using} = $code; |
1263
|
2
|
|
|
|
|
6
|
$data->{overwrite} = 1; |
1264
|
|
|
|
|
|
|
|
1265
|
2
|
|
|
|
|
13
|
$self->register_method($name, $data); |
1266
|
|
|
|
|
|
|
|
1267
|
2
|
|
|
|
|
6
|
return $self; |
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
} |
1270
|
|
|
|
|
|
|
|
1271
|
|
|
|
|
|
|
sub register_field { |
1272
|
|
|
|
|
|
|
|
1273
|
148
|
|
|
148
|
0
|
297
|
my ($self, $name, $data) = @_; |
1274
|
|
|
|
|
|
|
|
1275
|
148
|
|
|
|
|
529
|
my $package = $self->package; |
1276
|
148
|
|
|
|
|
284
|
my $merge = 0; |
1277
|
|
|
|
|
|
|
|
1278
|
148
|
100
|
|
|
|
508
|
$merge = 2 if $name =~ s/^\+{2}//; |
1279
|
148
|
100
|
|
|
|
434
|
$merge = 1 if $name =~ s/^\+{1}//; |
1280
|
|
|
|
|
|
|
|
1281
|
148
|
50
|
|
|
|
916
|
confess "Error creating field $name, name is not properly formatted" |
1282
|
|
|
|
|
|
|
unless $name =~ /^(?:[a-zA-Z_](?:[\w\.]*\w|\w*)(?:\:\d+)?)$/; |
1283
|
|
|
|
|
|
|
|
1284
|
148
|
100
|
|
|
|
665
|
if ($merge) { |
1285
|
2
|
100
|
66
|
|
|
8
|
if ($self->configuration->fields->has($name) && $merge == 2) { |
1286
|
1
|
|
|
|
|
5
|
$self->configuration->fields->get($name)->merge($data); |
1287
|
1
|
|
|
|
|
4
|
return $self; |
1288
|
|
|
|
|
|
|
} |
1289
|
|
|
|
|
|
|
|
1290
|
1
|
50
|
33
|
|
|
5
|
if ($self->configuration->fields->has($name) && $merge == 1) { |
1291
|
1
|
|
|
|
|
4
|
$self->configuration->fields->delete($name); |
1292
|
1
|
|
|
|
|
4
|
$self->configuration->fields->add($name, $data); |
1293
|
1
|
|
|
|
|
4
|
return $self; |
1294
|
|
|
|
|
|
|
} |
1295
|
|
|
|
|
|
|
} |
1296
|
|
|
|
|
|
|
|
1297
|
146
|
50
|
|
|
|
584
|
confess "Error creating accessor $name on $package: attribute collision" |
1298
|
|
|
|
|
|
|
if $self->fields->has($name); |
1299
|
|
|
|
|
|
|
|
1300
|
146
|
50
|
|
|
|
1507
|
confess "Error creating accessor $name on $package: method collision" |
1301
|
|
|
|
|
|
|
if $package->can($name); |
1302
|
|
|
|
|
|
|
|
1303
|
146
|
|
|
|
|
351
|
$data->{name} = $name; |
1304
|
|
|
|
|
|
|
|
1305
|
146
|
|
|
|
|
621
|
$self->configuration->fields->add($name, $data); |
1306
|
|
|
|
|
|
|
|
1307
|
146
|
|
|
|
|
291
|
my $method_name = $name; |
1308
|
|
|
|
|
|
|
|
1309
|
146
|
|
|
|
|
403
|
$method_name =~ s/\W/_/g; |
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
my $method_routine = sub { |
1312
|
|
|
|
|
|
|
|
1313
|
81
|
|
|
81
|
|
10525
|
my $self = shift @_; |
1314
|
|
|
|
|
|
|
|
1315
|
81
|
|
|
|
|
357
|
my $proto = $self->proto; |
1316
|
81
|
|
|
|
|
310
|
my $field = $proto->fields->get($name); |
1317
|
|
|
|
|
|
|
|
1318
|
81
|
100
|
|
|
|
278
|
if (@_ == 1) { |
1319
|
64
|
|
|
|
|
231
|
$proto->params->add($name, $_[0]); |
1320
|
63
|
|
|
|
|
305
|
$field->value($_[0]); |
1321
|
|
|
|
|
|
|
} |
1322
|
|
|
|
|
|
|
|
1323
|
80
|
|
|
|
|
259
|
return $proto->params->get($name); |
1324
|
|
|
|
|
|
|
|
1325
|
146
|
|
|
|
|
702
|
}; |
1326
|
|
|
|
|
|
|
|
1327
|
146
|
|
|
|
|
511
|
$self->set_method($method_name, $method_routine); |
1328
|
|
|
|
|
|
|
|
1329
|
146
|
|
|
|
|
427
|
return $self; |
1330
|
|
|
|
|
|
|
|
1331
|
|
|
|
|
|
|
} |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
sub register_filter { |
1334
|
|
|
|
|
|
|
|
1335
|
1
|
|
|
1
|
0
|
4
|
my ($self, $name, $code) = @_; |
1336
|
|
|
|
|
|
|
|
1337
|
1
|
|
|
|
|
6
|
$self->configuration->filters->add($name, $code); |
1338
|
|
|
|
|
|
|
|
1339
|
1
|
|
|
|
|
3
|
return $self; |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
} |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
sub register_message { |
1344
|
|
|
|
|
|
|
|
1345
|
0
|
|
|
0
|
0
|
0
|
my ($self, $name, $template) = @_; |
1346
|
|
|
|
|
|
|
|
1347
|
0
|
|
|
|
|
0
|
$self->messages->add($name, $template); |
1348
|
|
|
|
|
|
|
|
1349
|
0
|
|
|
|
|
0
|
return $self; |
1350
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
} |
1352
|
|
|
|
|
|
|
|
1353
|
|
|
|
|
|
|
sub register_method { |
1354
|
|
|
|
|
|
|
|
1355
|
18
|
|
|
18
|
0
|
40
|
my ($self, $name, $data) = @_; |
1356
|
|
|
|
|
|
|
|
1357
|
18
|
|
|
|
|
67
|
my $package = $self->package; |
1358
|
|
|
|
|
|
|
|
1359
|
18
|
100
|
|
|
|
76
|
unless ($data->{overwrite}) { |
1360
|
|
|
|
|
|
|
|
1361
|
16
|
50
|
|
|
|
74
|
confess |
1362
|
|
|
|
|
|
|
"Error creating method $name on $package: ". |
1363
|
|
|
|
|
|
|
"collides with attribute $name" |
1364
|
|
|
|
|
|
|
if $self->attributes->has($name) |
1365
|
|
|
|
|
|
|
; |
1366
|
16
|
50
|
|
|
|
294
|
confess |
1367
|
|
|
|
|
|
|
"Error creating method $name on $package: ". |
1368
|
|
|
|
|
|
|
"collides with method $name" |
1369
|
|
|
|
|
|
|
if $package->can($name) |
1370
|
|
|
|
|
|
|
; |
1371
|
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
} |
1373
|
|
|
|
|
|
|
|
1374
|
18
|
|
|
|
|
85
|
my @output_keys = my @input_keys = qw( |
1375
|
|
|
|
|
|
|
input input_document input_profile input_method |
1376
|
|
|
|
|
|
|
); |
1377
|
|
|
|
|
|
|
|
1378
|
18
|
|
|
|
|
185
|
s/input/output/ for @output_keys; |
1379
|
|
|
|
|
|
|
|
1380
|
|
|
|
|
|
|
confess |
1381
|
|
|
|
|
|
|
"Error creating method $name, requires " . |
1382
|
|
|
|
|
|
|
"at-least one pre or post-condition option, e.g., " . |
1383
|
0
|
|
|
|
|
0
|
join ', or ', map { "'$_'" } sort @input_keys, @output_keys |
1384
|
18
|
50
|
|
|
|
40
|
unless grep { $data->{$_} } @input_keys, @output_keys |
|
144
|
|
|
|
|
275
|
|
1385
|
|
|
|
|
|
|
; |
1386
|
|
|
|
|
|
|
|
1387
|
18
|
|
100
|
|
|
85
|
$data->{using} ||= $package->can("_$name"); |
1388
|
18
|
|
66
|
|
|
79
|
$data->{using} ||= $package->can("_process_$name"); |
1389
|
|
|
|
|
|
|
|
1390
|
|
|
|
|
|
|
confess |
1391
|
|
|
|
|
|
|
"Error creating method $name, requires the " . |
1392
|
|
|
|
|
|
|
"'using' option and a coderef or subroutine which conforms ". |
1393
|
|
|
|
|
|
|
"to the naming conventions suggested in the documentation" |
1394
|
|
|
|
|
|
|
unless "CODE" eq ref $data->{using} |
1395
|
18
|
50
|
|
|
|
86
|
; |
1396
|
|
|
|
|
|
|
|
1397
|
18
|
|
|
|
|
98
|
$self->configuration->methods->add($name, $data); |
1398
|
|
|
|
|
|
|
|
1399
|
|
|
|
|
|
|
# create method |
1400
|
|
|
|
|
|
|
|
1401
|
108
|
|
|
108
|
|
687
|
no strict 'refs'; |
|
108
|
|
|
|
|
230
|
|
|
108
|
|
|
|
|
168660
|
|
1402
|
|
|
|
|
|
|
|
1403
|
|
|
|
|
|
|
my $method_routine = sub { |
1404
|
|
|
|
|
|
|
|
1405
|
47
|
|
|
47
|
|
6852
|
my $self = shift; |
1406
|
47
|
|
|
|
|
93
|
my @args = @_; |
1407
|
|
|
|
|
|
|
|
1408
|
47
|
|
|
|
|
75
|
my $i_validator; |
1409
|
|
|
|
|
|
|
my $o_validator; |
1410
|
|
|
|
|
|
|
|
1411
|
47
|
|
|
55
|
|
369
|
my $input_type = firstval { defined $data->{$_} } @input_keys; |
|
57
|
|
|
|
|
169
|
|
1412
|
47
|
|
|
150
|
|
281
|
my $output_type = firstval { defined $data->{$_} } @output_keys; |
|
158
|
|
|
|
|
287
|
|
1413
|
47
|
100
|
|
|
|
218
|
my $input = $input_type ? $data->{$input_type} : ''; |
1414
|
47
|
100
|
|
|
|
133
|
my $output = $output_type ? $data->{$output_type} : ''; |
1415
|
47
|
|
|
|
|
99
|
my $using = $data->{'using'}; |
1416
|
47
|
|
|
|
|
76
|
my $return = undef; |
1417
|
|
|
|
|
|
|
|
1418
|
47
|
100
|
100
|
|
|
273
|
if ($input and $input_type eq 'input') { |
|
|
100
|
|
|
|
|
|
1419
|
|
|
|
|
|
|
|
1420
|
41
|
100
|
|
|
|
187
|
if (isa_arrayref($input)) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1421
|
33
|
|
|
31
|
|
142
|
$i_validator = sub {$self->validate(@{$input})}; |
|
33
|
|
|
|
|
44
|
|
|
33
|
|
|
|
|
189
|
|
1422
|
|
|
|
|
|
|
} |
1423
|
|
|
|
|
|
|
|
1424
|
|
|
|
|
|
|
elsif ($self->proto->profiles->get($input)) { |
1425
|
6
|
|
|
6
|
|
33
|
$i_validator = sub {$self->validate_profile($input, @args)}; |
|
6
|
|
|
|
|
33
|
|
1426
|
|
|
|
|
|
|
} |
1427
|
|
|
|
|
|
|
|
1428
|
|
|
|
|
|
|
elsif ($self->proto->methods->get($input)) { |
1429
|
2
|
|
|
2
|
|
10
|
$i_validator = sub {$self->validate_method($input, @args)}; |
|
2
|
|
|
|
|
11
|
|
1430
|
|
|
|
|
|
|
} |
1431
|
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
|
else { |
1433
|
0
|
|
|
|
|
0
|
confess "Method $name has an invalid input specification"; |
1434
|
|
|
|
|
|
|
} |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
elsif ($input) { |
1439
|
|
|
|
|
|
|
|
1440
|
4
|
|
|
|
|
6
|
my $type = $input_type; |
1441
|
4
|
|
|
|
|
16
|
$type =~ s/input_//; |
1442
|
|
|
|
|
|
|
|
1443
|
4
|
|
|
|
|
9
|
my $type_list = "${type}s"; |
1444
|
4
|
|
|
|
|
7
|
my $type_validator = "validate_${type}"; |
1445
|
|
|
|
|
|
|
|
1446
|
4
|
50
|
33
|
|
|
35
|
if ($type && $type_list && $self->proto->$type_list->get($input)) { |
|
|
|
33
|
|
|
|
|
1447
|
4
|
|
|
4
|
|
16
|
$i_validator = sub {$self->$type_validator($input, @args)}; |
|
4
|
|
|
|
|
18
|
|
1448
|
|
|
|
|
|
|
} |
1449
|
|
|
|
|
|
|
|
1450
|
|
|
|
|
|
|
else { |
1451
|
0
|
|
|
|
|
0
|
confess "Method $name has an invalid input specification"; |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
} |
1455
|
|
|
|
|
|
|
|
1456
|
47
|
100
|
66
|
|
|
277
|
if ($output and $output_type eq 'output') { |
|
|
50
|
|
|
|
|
|
1457
|
|
|
|
|
|
|
|
1458
|
10
|
100
|
|
|
|
32
|
if (isa_arrayref($output)) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1459
|
7
|
|
|
5
|
|
30
|
$o_validator = sub {$self->validate(@{$output})}; |
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
23
|
|
1460
|
|
|
|
|
|
|
} |
1461
|
|
|
|
|
|
|
|
1462
|
|
|
|
|
|
|
elsif ($self->proto->profiles->get($output)) { |
1463
|
3
|
|
|
2
|
|
14
|
$o_validator = sub {$self->validate_profile($output, @args)}; |
|
2
|
|
|
|
|
10
|
|
1464
|
|
|
|
|
|
|
} |
1465
|
|
|
|
|
|
|
|
1466
|
|
|
|
|
|
|
elsif ($self->proto->methods->get($output)) { |
1467
|
0
|
|
|
0
|
|
0
|
$o_validator = sub {$self->validate_method($output, @args)}; |
|
0
|
|
|
|
|
0
|
|
1468
|
|
|
|
|
|
|
} |
1469
|
|
|
|
|
|
|
|
1470
|
|
|
|
|
|
|
else { |
1471
|
0
|
|
|
|
|
0
|
confess "Method $name has an invalid output specification"; |
1472
|
|
|
|
|
|
|
} |
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
} |
1475
|
|
|
|
|
|
|
|
1476
|
|
|
|
|
|
|
elsif ($output) { |
1477
|
|
|
|
|
|
|
|
1478
|
0
|
|
|
|
|
0
|
my $type = $output_type; |
1479
|
0
|
|
|
|
|
0
|
$type =~ s/output_//; |
1480
|
|
|
|
|
|
|
|
1481
|
0
|
|
|
|
|
0
|
my $type_list = "${type}s"; |
1482
|
0
|
|
|
|
|
0
|
my $type_validator = "validate_${type}"; |
1483
|
|
|
|
|
|
|
|
1484
|
0
|
0
|
0
|
|
|
0
|
if ($type && $type_list && $self->proto->$type_list->get($output)) { |
|
|
|
0
|
|
|
|
|
1485
|
0
|
|
|
0
|
|
0
|
$o_validator = sub {$self->$type_validator($output, @args)}; |
|
0
|
|
|
|
|
0
|
|
1486
|
|
|
|
|
|
|
} |
1487
|
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
|
else { |
1489
|
0
|
|
|
|
|
0
|
confess "Method $name has an invalid output specification"; |
1490
|
|
|
|
|
|
|
} |
1491
|
|
|
|
|
|
|
|
1492
|
|
|
|
|
|
|
} |
1493
|
|
|
|
|
|
|
|
1494
|
47
|
50
|
|
|
|
134
|
if ($using) { |
1495
|
|
|
|
|
|
|
|
1496
|
47
|
50
|
|
|
|
160
|
if (isa_coderef($using)) { |
1497
|
|
|
|
|
|
|
|
1498
|
47
|
|
|
|
|
140
|
my $error = "Method $name failed to validate"; |
1499
|
|
|
|
|
|
|
|
1500
|
|
|
|
|
|
|
# execute input validation |
1501
|
47
|
100
|
|
|
|
118
|
if ($input) { |
1502
|
45
|
100
|
|
|
|
97
|
unless ($i_validator->(@args)) { |
1503
|
11
|
50
|
|
|
|
68
|
confess $error. " input, ". $self->errors_to_string |
1504
|
|
|
|
|
|
|
if !$self->ignore_failure; |
1505
|
11
|
50
|
|
|
|
54
|
unshift @{$self->errors}, $error |
|
0
|
|
|
|
|
0
|
|
1506
|
|
|
|
|
|
|
if $self->report_failure; |
1507
|
11
|
|
|
|
|
126
|
return $return; |
1508
|
|
|
|
|
|
|
} |
1509
|
|
|
|
|
|
|
} |
1510
|
|
|
|
|
|
|
|
1511
|
|
|
|
|
|
|
# execute routine |
1512
|
36
|
|
|
|
|
182
|
$return = $using->($self, @args); |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
# execute output validation |
1515
|
36
|
100
|
|
|
|
153
|
if ($output) { |
1516
|
7
|
100
|
|
|
|
21
|
confess $error. " output, ". $self->errors_to_string |
1517
|
|
|
|
|
|
|
unless $o_validator->(@args); |
1518
|
|
|
|
|
|
|
} |
1519
|
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
# return |
1521
|
34
|
|
|
|
|
374
|
return $return; |
1522
|
|
|
|
|
|
|
|
1523
|
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
else { |
1526
|
|
|
|
|
|
|
|
1527
|
0
|
|
|
|
|
0
|
confess "Error executing $name, invalid coderef specification"; |
1528
|
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
|
} |
1530
|
|
|
|
|
|
|
|
1531
|
|
|
|
|
|
|
} |
1532
|
|
|
|
|
|
|
|
1533
|
0
|
|
|
|
|
0
|
return $return; |
1534
|
|
|
|
|
|
|
|
1535
|
18
|
|
|
|
|
174
|
}; |
1536
|
|
|
|
|
|
|
|
1537
|
18
|
|
|
|
|
68
|
$self->set_method($name, $method_routine); |
1538
|
|
|
|
|
|
|
|
1539
|
18
|
|
|
|
|
59
|
return $self; |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
}; |
1542
|
|
|
|
|
|
|
|
1543
|
|
|
|
|
|
|
sub register_mixin { |
1544
|
|
|
|
|
|
|
|
1545
|
19
|
|
|
19
|
0
|
45
|
my ($self, $name, $data) = @_; |
1546
|
|
|
|
|
|
|
|
1547
|
19
|
|
|
|
|
79
|
my $mixins = $self->configuration->mixins; |
1548
|
19
|
|
|
|
|
44
|
my $merge = 0; |
1549
|
|
|
|
|
|
|
|
1550
|
19
|
50
|
|
|
|
80
|
$merge = 2 if $name =~ s/^\+{2}//; |
1551
|
19
|
50
|
|
|
|
68
|
$merge = 1 if $name =~ s/^\+{1}//; |
1552
|
|
|
|
|
|
|
|
1553
|
19
|
|
|
|
|
47
|
$data->{name} = $name; |
1554
|
|
|
|
|
|
|
|
1555
|
19
|
50
|
33
|
|
|
120
|
if ($mixins->has($name) && $merge == 2) { |
1556
|
0
|
|
|
|
|
0
|
$mixins->get($name)->merge($data); |
1557
|
0
|
|
|
|
|
0
|
return $self; |
1558
|
|
|
|
|
|
|
} |
1559
|
|
|
|
|
|
|
|
1560
|
19
|
50
|
33
|
|
|
82
|
if ($mixins->has($name) && $merge == 1) { |
1561
|
0
|
|
|
|
|
0
|
$mixins->delete($name); |
1562
|
0
|
|
|
|
|
0
|
$mixins->add($name, $data); |
1563
|
0
|
|
|
|
|
0
|
return $self; |
1564
|
|
|
|
|
|
|
} |
1565
|
|
|
|
|
|
|
|
1566
|
19
|
|
|
|
|
79
|
$mixins->add($name, $data); |
1567
|
|
|
|
|
|
|
|
1568
|
19
|
|
|
|
|
57
|
return $self; |
1569
|
|
|
|
|
|
|
|
1570
|
|
|
|
|
|
|
} |
1571
|
|
|
|
|
|
|
|
1572
|
|
|
|
|
|
|
sub register_profile { |
1573
|
|
|
|
|
|
|
|
1574
|
11
|
|
|
11
|
0
|
45
|
my ($self, $name, $code) = @_; |
1575
|
|
|
|
|
|
|
|
1576
|
11
|
|
|
|
|
44
|
$self->configuration->profiles->add($name, $code); |
1577
|
|
|
|
|
|
|
|
1578
|
11
|
|
|
|
|
32
|
return $self; |
1579
|
|
|
|
|
|
|
|
1580
|
|
|
|
|
|
|
} |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
sub register_settings { |
1583
|
|
|
|
|
|
|
|
1584
|
17
|
|
|
17
|
0
|
40
|
my ($self, $data) = @_; |
1585
|
|
|
|
|
|
|
|
1586
|
17
|
|
|
|
|
29
|
my @keys; |
1587
|
|
|
|
|
|
|
|
1588
|
17
|
|
|
|
|
70
|
my $name = $self->package; |
1589
|
|
|
|
|
|
|
|
1590
|
|
|
|
|
|
|
# grab configuration settings, not instance settings |
1591
|
|
|
|
|
|
|
|
1592
|
17
|
|
|
|
|
106
|
my $settings = $self->configuration->settings; |
1593
|
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
|
# attach classes |
1595
|
17
|
|
|
|
|
65
|
@keys = qw(class classes); |
1596
|
17
|
100
|
|
34
|
|
312
|
if (my $alias = firstval { exists $data->{$_} } @keys) { |
|
34
|
|
|
|
|
118
|
|
1597
|
|
|
|
|
|
|
|
1598
|
4
|
|
|
|
|
9
|
$alias = $data->{$alias}; |
1599
|
|
|
|
|
|
|
|
1600
|
4
|
|
|
|
|
7
|
my @parents; |
1601
|
|
|
|
|
|
|
|
1602
|
4
|
100
|
66
|
|
|
39
|
if ($alias eq 1 && !ref $alias) { |
1603
|
|
|
|
|
|
|
|
1604
|
3
|
|
|
|
|
8
|
push @parents, $name; |
1605
|
|
|
|
|
|
|
|
1606
|
|
|
|
|
|
|
} |
1607
|
|
|
|
|
|
|
|
1608
|
|
|
|
|
|
|
else { |
1609
|
|
|
|
|
|
|
|
1610
|
1
|
50
|
|
|
|
6
|
push @parents, isa_arrayref($alias) ? @{$alias} : $alias; |
|
1
|
|
|
|
|
3
|
|
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
} |
1613
|
|
|
|
|
|
|
|
1614
|
4
|
|
|
|
|
10
|
foreach my $parent (@parents) { |
1615
|
|
|
|
|
|
|
|
1616
|
4
|
|
50
|
|
|
29
|
my $relatives = $settings->{relatives}->{$parent} ||= {}; |
1617
|
|
|
|
|
|
|
|
1618
|
|
|
|
|
|
|
# load class children and create relationship map (hash) |
1619
|
|
|
|
|
|
|
|
1620
|
4
|
|
|
|
|
20
|
foreach my $child (findallmod $parent) { |
1621
|
|
|
|
|
|
|
|
1622
|
17
|
|
|
|
|
7042
|
my $name = $child; |
1623
|
17
|
|
|
|
|
165
|
$name =~ s/^$parent\:://; |
1624
|
|
|
|
|
|
|
|
1625
|
17
|
|
|
|
|
57
|
$relatives->{$name} = $child; |
1626
|
|
|
|
|
|
|
|
1627
|
|
|
|
|
|
|
} |
1628
|
|
|
|
|
|
|
|
1629
|
|
|
|
|
|
|
} |
1630
|
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
} |
1632
|
|
|
|
|
|
|
|
1633
|
|
|
|
|
|
|
# attach requirements |
1634
|
17
|
|
|
|
|
111
|
@keys = qw(requires required requirement requirements); |
1635
|
17
|
100
|
|
64
|
|
97
|
if (my $alias = firstval { exists $data->{$_} } @keys) { |
|
64
|
|
|
|
|
150
|
|
1636
|
|
|
|
|
|
|
|
1637
|
2
|
|
|
|
|
5
|
$alias = $data->{$alias}; |
1638
|
|
|
|
|
|
|
|
1639
|
2
|
|
|
|
|
3
|
my @requirements; |
1640
|
|
|
|
|
|
|
|
1641
|
2
|
50
|
|
|
|
7
|
push @requirements, isa_arrayref($alias) ? @{$alias} : $alias; |
|
0
|
|
|
|
|
0
|
|
1642
|
|
|
|
|
|
|
|
1643
|
2
|
|
|
|
|
6
|
foreach my $requirement (@requirements) { |
1644
|
|
|
|
|
|
|
|
1645
|
2
|
|
|
|
|
10
|
$settings->{requirements}->{$requirement} = 1; |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
} |
1648
|
|
|
|
|
|
|
|
1649
|
|
|
|
|
|
|
} |
1650
|
|
|
|
|
|
|
|
1651
|
|
|
|
|
|
|
# attach roles |
1652
|
17
|
|
|
|
|
85
|
@keys = qw(base role roles bases); |
1653
|
17
|
100
|
|
49
|
|
78
|
if (my $alias = firstval { exists $data->{$_} } @keys) { |
|
49
|
|
|
|
|
117
|
|
1654
|
|
|
|
|
|
|
|
1655
|
10
|
|
|
|
|
28
|
$alias = $data->{$alias}; |
1656
|
|
|
|
|
|
|
|
1657
|
10
|
|
|
|
|
21
|
my @roles; |
1658
|
|
|
|
|
|
|
|
1659
|
10
|
50
|
|
|
|
35
|
if ($alias) { |
1660
|
|
|
|
|
|
|
|
1661
|
10
|
100
|
|
|
|
43
|
push @roles, isa_arrayref($alias) ? @{$alias} : $alias; |
|
3
|
|
|
|
|
13
|
|
1662
|
|
|
|
|
|
|
|
1663
|
|
|
|
|
|
|
} |
1664
|
|
|
|
|
|
|
|
1665
|
10
|
50
|
|
|
|
55
|
if (@roles) { |
1666
|
|
|
|
|
|
|
|
1667
|
108
|
|
|
108
|
|
693
|
no strict 'refs'; |
|
108
|
|
|
|
|
333
|
|
|
108
|
|
|
|
|
99059
|
|
1668
|
|
|
|
|
|
|
|
1669
|
10
|
|
|
|
|
30
|
foreach my $role (@roles) { |
1670
|
|
|
|
|
|
|
|
1671
|
12
|
|
|
|
|
28
|
eval { use_module $role }; |
|
12
|
|
|
|
|
55
|
|
1672
|
|
|
|
|
|
|
|
1673
|
|
|
|
|
|
|
# is the role a validation class? |
1674
|
|
|
|
|
|
|
|
1675
|
12
|
50
|
|
|
|
4035
|
unless ($self->registry->has($role)) { |
1676
|
0
|
|
|
|
|
0
|
confess sprintf |
1677
|
|
|
|
|
|
|
"Can't apply the role %s to the " . |
1678
|
|
|
|
|
|
|
"class %s unless the role uses Validation::Class", |
1679
|
|
|
|
|
|
|
$role, |
1680
|
|
|
|
|
|
|
$self->package |
1681
|
|
|
|
|
|
|
; |
1682
|
|
|
|
|
|
|
} |
1683
|
|
|
|
|
|
|
|
1684
|
12
|
|
|
|
|
43
|
my $role_proto = $self->registry->get($role);; |
1685
|
|
|
|
|
|
|
|
1686
|
|
|
|
|
|
|
# check requirements |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
my $requirements = |
1689
|
12
|
|
|
|
|
51
|
$role_proto->configuration->settings->{requirements}; |
1690
|
|
|
|
|
|
|
; |
1691
|
|
|
|
|
|
|
|
1692
|
12
|
100
|
|
|
|
46
|
if (defined $requirements) { |
1693
|
|
|
|
|
|
|
|
1694
|
2
|
|
|
|
|
3
|
my @failures; |
1695
|
|
|
|
|
|
|
|
1696
|
2
|
|
|
|
|
4
|
foreach my $requirement (keys %{$requirements}) { |
|
2
|
|
|
|
|
6
|
|
1697
|
2
|
100
|
|
|
|
7
|
unless ($self->package->can($requirement)) { |
1698
|
1
|
|
|
|
|
9
|
push @failures, $requirement; |
1699
|
|
|
|
|
|
|
} |
1700
|
|
|
|
|
|
|
} |
1701
|
|
|
|
|
|
|
|
1702
|
2
|
100
|
|
|
|
8
|
if (@failures) { |
1703
|
1
|
|
|
|
|
5
|
confess sprintf |
1704
|
|
|
|
|
|
|
"Can't use the class %s as a role for ". |
1705
|
|
|
|
|
|
|
"use with the class %s while missing method(s): %s", |
1706
|
|
|
|
|
|
|
$role, |
1707
|
|
|
|
|
|
|
$self->package, |
1708
|
|
|
|
|
|
|
join ', ', @failures |
1709
|
|
|
|
|
|
|
; |
1710
|
|
|
|
|
|
|
} |
1711
|
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
|
} |
1713
|
|
|
|
|
|
|
|
1714
|
11
|
|
|
|
|
22
|
push @{$settings->{roles}}, $role; |
|
11
|
|
|
|
|
40
|
|
1715
|
|
|
|
|
|
|
|
1716
|
|
|
|
|
|
|
my @routines = |
1717
|
11
|
|
|
|
|
25
|
grep { defined &{"$role\::$_"} } keys %{"$role\::"}; |
|
784
|
|
|
|
|
857
|
|
|
784
|
|
|
|
|
2696
|
|
|
11
|
|
|
|
|
207
|
|
1718
|
|
|
|
|
|
|
|
1719
|
11
|
50
|
|
|
|
85
|
if (@routines) { |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
# copy methods |
1722
|
|
|
|
|
|
|
|
1723
|
11
|
|
|
|
|
27
|
foreach my $routine (@routines) { |
1724
|
|
|
|
|
|
|
|
1725
|
762
|
100
|
|
|
|
1903
|
eval { |
1726
|
|
|
|
|
|
|
|
1727
|
37
|
|
|
|
|
186
|
$self->set_method($routine, $role->can($routine)); |
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
} unless $self->package->can($routine); |
1730
|
|
|
|
|
|
|
|
1731
|
|
|
|
|
|
|
} |
1732
|
|
|
|
|
|
|
|
1733
|
|
|
|
|
|
|
# merge configurations |
1734
|
|
|
|
|
|
|
|
1735
|
11
|
|
|
|
|
43
|
my $self_profile = $self->configuration->profile; |
1736
|
11
|
|
|
|
|
41
|
my $role_profile = $role_proto->configuration->profile; |
1737
|
|
|
|
|
|
|
|
1738
|
|
|
|
|
|
|
# manually merge profiles with list/map containers |
1739
|
|
|
|
|
|
|
|
1740
|
11
|
|
|
|
|
51
|
foreach my $attr ($self_profile->keys) { |
1741
|
|
|
|
|
|
|
|
1742
|
121
|
|
|
|
|
177
|
my $lst = 'Validation::Class::Listing'; |
1743
|
121
|
|
|
|
|
173
|
my $map = 'Validation::Class::Mapping'; |
1744
|
|
|
|
|
|
|
|
1745
|
121
|
|
|
|
|
192
|
my $sp_attr = $self_profile->{$attr}; |
1746
|
121
|
|
|
|
|
181
|
my $rp_attr = $role_profile->{$attr}; |
1747
|
|
|
|
|
|
|
|
1748
|
121
|
100
|
66
|
|
|
888
|
if (ref($rp_attr) and $rp_attr->isa($map)) { |
|
|
50
|
33
|
|
|
|
|
1749
|
110
|
|
|
|
|
328
|
$sp_attr->merge($rp_attr->hash); |
1750
|
|
|
|
|
|
|
} |
1751
|
|
|
|
|
|
|
|
1752
|
|
|
|
|
|
|
elsif (ref($rp_attr) and $rp_attr->isa($lst)) { |
1753
|
11
|
|
|
|
|
55
|
$sp_attr->add($rp_attr->list); |
1754
|
|
|
|
|
|
|
} |
1755
|
|
|
|
|
|
|
|
1756
|
|
|
|
|
|
|
else { |
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
# merge via spec-based merging for standard types |
1759
|
|
|
|
|
|
|
|
1760
|
0
|
|
|
|
|
0
|
Hash::Merge::set_behavior('ROLE_PRECEDENT'); |
1761
|
|
|
|
|
|
|
|
1762
|
0
|
|
|
|
|
0
|
$sp_attr = merge $sp_attr => $rp_attr; |
1763
|
|
|
|
|
|
|
|
1764
|
0
|
|
|
|
|
0
|
Hash::Merge::set_behavior('LEFT_PRECEDENT'); |
1765
|
|
|
|
|
|
|
|
1766
|
|
|
|
|
|
|
} |
1767
|
|
|
|
|
|
|
|
1768
|
|
|
|
|
|
|
} |
1769
|
|
|
|
|
|
|
|
1770
|
|
|
|
|
|
|
} |
1771
|
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
} |
1773
|
|
|
|
|
|
|
|
1774
|
|
|
|
|
|
|
} |
1775
|
|
|
|
|
|
|
|
1776
|
|
|
|
|
|
|
} |
1777
|
|
|
|
|
|
|
|
1778
|
16
|
|
|
|
|
106
|
return $self; |
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
} |
1781
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
sub registry { |
1783
|
|
|
|
|
|
|
|
1784
|
1525
|
|
|
1525
|
0
|
6340
|
return $_registry; |
1785
|
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
} |
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
|
1789
|
|
|
|
|
|
|
sub reset { |
1790
|
|
|
|
|
|
|
|
1791
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1792
|
|
|
|
|
|
|
|
1793
|
0
|
|
|
|
|
0
|
$self->queued->clear; |
1794
|
|
|
|
|
|
|
|
1795
|
0
|
|
|
|
|
0
|
$self->reset_fields; |
1796
|
|
|
|
|
|
|
|
1797
|
0
|
|
|
|
|
0
|
$self->reset_params; |
1798
|
|
|
|
|
|
|
|
1799
|
0
|
|
|
|
|
0
|
return $self; |
1800
|
|
|
|
|
|
|
|
1801
|
|
|
|
|
|
|
} |
1802
|
|
|
|
|
|
|
|
1803
|
|
|
|
|
|
|
|
1804
|
|
|
|
|
|
|
sub reset_errors { |
1805
|
|
|
|
|
|
|
|
1806
|
628
|
|
|
628
|
1
|
1029
|
my $self = shift; |
1807
|
|
|
|
|
|
|
|
1808
|
628
|
|
|
|
|
2054
|
$self->errors->clear; |
1809
|
|
|
|
|
|
|
|
1810
|
628
|
|
|
|
|
2123
|
foreach my $field ($self->fields->values) { |
1811
|
|
|
|
|
|
|
|
1812
|
1034
|
|
|
|
|
3222
|
$field->errors->clear; |
1813
|
|
|
|
|
|
|
|
1814
|
|
|
|
|
|
|
} |
1815
|
|
|
|
|
|
|
|
1816
|
628
|
|
|
|
|
1787
|
return $self; |
1817
|
|
|
|
|
|
|
|
1818
|
|
|
|
|
|
|
} |
1819
|
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
|
|
1821
|
|
|
|
|
|
|
sub reset_fields { |
1822
|
|
|
|
|
|
|
|
1823
|
628
|
|
|
628
|
1
|
998
|
my $self = shift; |
1824
|
|
|
|
|
|
|
|
1825
|
628
|
|
|
|
|
2041
|
foreach my $field ( $self->fields->values ) { |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
# set default, special directives, etc |
1828
|
1034
|
|
|
|
|
3349
|
$field->{name} = $field->name; |
1829
|
1034
|
|
|
|
|
2547
|
$field->{value} = ''; |
1830
|
|
|
|
|
|
|
|
1831
|
|
|
|
|
|
|
} |
1832
|
|
|
|
|
|
|
|
1833
|
628
|
|
|
|
|
2621
|
$self->reset_errors(); |
1834
|
|
|
|
|
|
|
|
1835
|
628
|
|
|
|
|
1030
|
return $self; |
1836
|
|
|
|
|
|
|
|
1837
|
|
|
|
|
|
|
} |
1838
|
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
sub reset_params { |
1841
|
|
|
|
|
|
|
|
1842
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1843
|
|
|
|
|
|
|
|
1844
|
0
|
|
|
|
|
0
|
my $params = $self->build_args(@_); |
1845
|
|
|
|
|
|
|
|
1846
|
0
|
|
|
|
|
0
|
$self->params->clear; |
1847
|
|
|
|
|
|
|
|
1848
|
0
|
|
|
|
|
0
|
$self->params->add($params); |
1849
|
|
|
|
|
|
|
|
1850
|
0
|
|
|
|
|
0
|
return $self; |
1851
|
|
|
|
|
|
|
|
1852
|
|
|
|
|
|
|
} |
1853
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
|
1855
|
|
|
|
|
|
|
sub set_errors { |
1856
|
|
|
|
|
|
|
|
1857
|
8
|
|
|
8
|
1
|
21
|
my ($self, @errors) = @_; |
1858
|
|
|
|
|
|
|
|
1859
|
8
|
50
|
|
|
|
46
|
$self->errors->add(@errors) if @errors; |
1860
|
|
|
|
|
|
|
|
1861
|
8
|
|
|
|
|
131
|
return $self->errors->count; |
1862
|
|
|
|
|
|
|
|
1863
|
|
|
|
|
|
|
} |
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
|
1866
|
|
|
|
|
|
|
sub set_fields { |
1867
|
|
|
|
|
|
|
|
1868
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1869
|
|
|
|
|
|
|
|
1870
|
0
|
|
|
|
|
0
|
my $fields = $self->build_args(@_); |
1871
|
|
|
|
|
|
|
|
1872
|
0
|
|
|
|
|
0
|
$self->fields->add($fields); |
1873
|
|
|
|
|
|
|
|
1874
|
0
|
|
|
|
|
0
|
return $self; |
1875
|
|
|
|
|
|
|
|
1876
|
|
|
|
|
|
|
} |
1877
|
|
|
|
|
|
|
|
1878
|
|
|
|
|
|
|
sub set_method { |
1879
|
|
|
|
|
|
|
|
1880
|
5870
|
|
|
5870
|
0
|
9528
|
my ($self, $name, $code) = @_; |
1881
|
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
|
# proto and prototype methods cannot be overridden |
1883
|
|
|
|
|
|
|
|
1884
|
5870
|
50
|
33
|
|
|
28274
|
confess "Error creating method $name, method already exists" |
|
|
|
33
|
|
|
|
|
1885
|
|
|
|
|
|
|
if ($name eq 'proto' || $name eq 'prototype') |
1886
|
|
|
|
|
|
|
&& $self->package->can($name) |
1887
|
|
|
|
|
|
|
; |
1888
|
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
|
# place routines on the calling class |
1890
|
|
|
|
|
|
|
|
1891
|
108
|
|
|
108
|
|
634
|
no strict 'refs'; |
|
108
|
|
|
|
|
244
|
|
|
108
|
|
|
|
|
9590
|
|
1892
|
108
|
|
|
108
|
|
609
|
no warnings 'redefine'; |
|
108
|
|
|
|
|
220
|
|
|
108
|
|
|
|
|
370743
|
|
1893
|
|
|
|
|
|
|
|
1894
|
5870
|
|
|
|
|
6778
|
return *{join('::', $self->package, $name)} = $code; |
|
5870
|
|
|
|
|
15314
|
|
1895
|
|
|
|
|
|
|
|
1896
|
|
|
|
|
|
|
} |
1897
|
|
|
|
|
|
|
|
1898
|
|
|
|
|
|
|
|
1899
|
|
|
|
|
|
|
sub set_params { |
1900
|
|
|
|
|
|
|
|
1901
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1902
|
|
|
|
|
|
|
|
1903
|
0
|
|
|
|
|
0
|
$self->params->add(@_); |
1904
|
|
|
|
|
|
|
|
1905
|
0
|
|
|
|
|
0
|
return $self; |
1906
|
|
|
|
|
|
|
|
1907
|
|
|
|
|
|
|
} |
1908
|
|
|
|
|
|
|
|
1909
|
|
|
|
|
|
|
|
1910
|
|
|
|
|
|
|
sub set_values { |
1911
|
|
|
|
|
|
|
|
1912
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1913
|
|
|
|
|
|
|
|
1914
|
0
|
|
|
|
|
0
|
my $values = $self->build_args(@_); |
1915
|
|
|
|
|
|
|
|
1916
|
0
|
|
|
|
|
0
|
while (my($name, $value) = each(%{$values})) { |
|
0
|
|
|
|
|
0
|
|
1917
|
|
|
|
|
|
|
|
1918
|
0
|
|
|
|
|
0
|
my $param = $self->params->get($name); |
1919
|
0
|
|
|
|
|
0
|
my $field = $self->fields->get($name); |
1920
|
|
|
|
|
|
|
|
1921
|
0
|
0
|
|
|
|
0
|
next if $field->{readonly}; |
1922
|
|
|
|
|
|
|
|
1923
|
0
|
|
0
|
|
|
0
|
$value ||= $field->{default}; |
1924
|
|
|
|
|
|
|
|
1925
|
0
|
|
|
|
|
0
|
$self->params->add($name => $value); |
1926
|
|
|
|
|
|
|
|
1927
|
0
|
|
|
|
|
0
|
$field->value($value); |
1928
|
|
|
|
|
|
|
|
1929
|
|
|
|
|
|
|
} |
1930
|
|
|
|
|
|
|
|
1931
|
0
|
|
|
|
|
0
|
return $self; |
1932
|
|
|
|
|
|
|
|
1933
|
|
|
|
|
|
|
} |
1934
|
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
|
sub snapshot { |
1936
|
|
|
|
|
|
|
|
1937
|
165
|
|
|
165
|
0
|
367
|
my ($self) = @_; |
1938
|
|
|
|
|
|
|
|
1939
|
|
|
|
|
|
|
# reset the stash |
1940
|
|
|
|
|
|
|
|
1941
|
165
|
|
|
|
|
797
|
$self->stashed->clear; |
1942
|
|
|
|
|
|
|
|
1943
|
|
|
|
|
|
|
# clone configuration settings and merge into the prototype |
1944
|
|
|
|
|
|
|
# ... which makes the prototype kind've a snapshot of the configuration |
1945
|
|
|
|
|
|
|
|
1946
|
165
|
50
|
|
|
|
812
|
if (my $config = $self->configuration->configure_profile) { |
1947
|
|
|
|
|
|
|
|
1948
|
165
|
|
|
|
|
836
|
my @clonable_configuration_settings = qw( |
1949
|
|
|
|
|
|
|
attributes |
1950
|
|
|
|
|
|
|
directives |
1951
|
|
|
|
|
|
|
documents |
1952
|
|
|
|
|
|
|
events |
1953
|
|
|
|
|
|
|
fields |
1954
|
|
|
|
|
|
|
filters |
1955
|
|
|
|
|
|
|
methods |
1956
|
|
|
|
|
|
|
mixins |
1957
|
|
|
|
|
|
|
profiles |
1958
|
|
|
|
|
|
|
settings |
1959
|
|
|
|
|
|
|
); |
1960
|
|
|
|
|
|
|
|
1961
|
165
|
|
|
|
|
424
|
foreach my $name (@clonable_configuration_settings) { |
1962
|
|
|
|
|
|
|
|
1963
|
1650
|
|
|
|
|
6334
|
my $settings = $config->$name->hash; |
1964
|
|
|
|
|
|
|
|
1965
|
1650
|
|
|
|
|
8082
|
$self->$name->clear->merge($settings); |
1966
|
|
|
|
|
|
|
|
1967
|
|
|
|
|
|
|
} |
1968
|
|
|
|
|
|
|
|
1969
|
165
|
|
|
|
|
800
|
$self->builders->add($config->builders->list); |
1970
|
|
|
|
|
|
|
|
1971
|
|
|
|
|
|
|
} |
1972
|
|
|
|
|
|
|
|
1973
|
165
|
|
|
|
|
580
|
return $self; |
1974
|
|
|
|
|
|
|
|
1975
|
|
|
|
|
|
|
} |
1976
|
|
|
|
|
|
|
|
1977
|
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
|
sub stash { |
1979
|
|
|
|
|
|
|
|
1980
|
9539
|
|
|
9539
|
1
|
12908
|
my $self = shift; |
1981
|
|
|
|
|
|
|
|
1982
|
9539
|
100
|
100
|
|
|
24536
|
return $self->stashed->get($_[0]) if @_ == 1 && ! ref $_[0]; |
1983
|
|
|
|
|
|
|
|
1984
|
9535
|
100
|
100
|
|
|
22893
|
$self->stashed->add($_[0]->hash) if @_ == 1 && isa_mapping($_[0]); |
1985
|
9535
|
100
|
100
|
|
|
22545
|
$self->stashed->add($_[0]) if @_ == 1 && isa_hashref($_[0]); |
1986
|
9535
|
100
|
|
|
|
19838
|
$self->stashed->add(@_) if @_ > 1; |
1987
|
|
|
|
|
|
|
|
1988
|
9535
|
|
|
|
|
25449
|
return $self->stashed; |
1989
|
|
|
|
|
|
|
|
1990
|
|
|
|
|
|
|
} |
1991
|
|
|
|
|
|
|
|
1992
|
|
|
|
|
|
|
sub throw_error { |
1993
|
|
|
|
|
|
|
|
1994
|
2
|
|
|
2
|
0
|
5
|
my $error_message = pop; |
1995
|
|
|
|
|
|
|
|
1996
|
2
|
|
|
|
|
5
|
$error_message =~ s/\n/ /g; |
1997
|
2
|
|
|
|
|
16
|
$error_message =~ s/\s+/ /g; |
1998
|
|
|
|
|
|
|
|
1999
|
2
|
|
|
|
|
396
|
confess $error_message ; |
2000
|
|
|
|
|
|
|
|
2001
|
|
|
|
|
|
|
} |
2002
|
|
|
|
|
|
|
|
2003
|
|
|
|
|
|
|
sub trigger_event { |
2004
|
|
|
|
|
|
|
|
2005
|
2618
|
|
|
2618
|
0
|
4679
|
my ($self, $event, $field) = @_; |
2006
|
|
|
|
|
|
|
|
2007
|
2618
|
50
|
|
|
|
5665
|
return unless $event; |
2008
|
2618
|
50
|
|
|
|
5161
|
return unless $field; |
2009
|
|
|
|
|
|
|
|
2010
|
2618
|
|
|
|
|
3271
|
my @order; |
2011
|
|
|
|
|
|
|
my $directives; |
2012
|
2618
|
100
|
|
|
|
5513
|
my $process_all = $event eq 'on_normalize' ? 1 : 0; |
2013
|
2618
|
100
|
|
|
|
5166
|
my $event_type = $event eq 'on_normalize' ? 'normalization' : 'validation'; |
2014
|
|
|
|
|
|
|
|
2015
|
2618
|
|
|
|
|
7448
|
$event = $self->events->get($event); |
2016
|
2618
|
|
|
|
|
20883
|
$field = $self->fields->get($field); |
2017
|
|
|
|
|
|
|
|
2018
|
2618
|
50
|
|
|
|
6379
|
return unless defined $event; |
2019
|
2618
|
50
|
|
|
|
5385
|
return unless defined $field; |
2020
|
|
|
|
|
|
|
|
2021
|
|
|
|
|
|
|
# order events via dependency resolution |
2022
|
|
|
|
|
|
|
|
2023
|
|
|
|
|
|
|
$directives = Validation::Class::Directives->new( |
2024
|
2618
|
|
|
|
|
3509
|
{map{$_=>$self->directives->get($_)}(sort keys %{$event})} |
|
40851
|
|
|
|
|
104877
|
|
|
2618
|
|
|
|
|
24348
|
|
2025
|
|
|
|
|
|
|
); |
2026
|
2618
|
|
|
|
|
18606
|
@order = ($directives->resolve_dependencies($event_type)); |
2027
|
2618
|
50
|
|
|
|
8645
|
@order = keys(%{$event}) unless @order; |
|
0
|
|
|
|
|
0
|
|
2028
|
|
|
|
|
|
|
|
2029
|
|
|
|
|
|
|
# execute events |
2030
|
|
|
|
|
|
|
|
2031
|
2618
|
|
|
|
|
4724
|
foreach my $i (@order) { |
2032
|
|
|
|
|
|
|
|
2033
|
|
|
|
|
|
|
# skip if the field doesn't have the subscribing directive |
2034
|
40851
|
100
|
|
|
|
80522
|
unless ($process_all) { |
2035
|
28827
|
100
|
|
|
|
70360
|
next unless exists $field->{$i}; |
2036
|
|
|
|
|
|
|
} |
2037
|
|
|
|
|
|
|
|
2038
|
20918
|
|
|
|
|
32571
|
my $routine = $event->{$i}; |
2039
|
20918
|
|
|
|
|
57641
|
my $directive = $directives->get($i); |
2040
|
|
|
|
|
|
|
|
2041
|
|
|
|
|
|
|
# something else might fudge with the params so we wait |
2042
|
|
|
|
|
|
|
# until now to collect its value |
2043
|
20918
|
|
|
|
|
58737
|
my $name = $field->name; |
2044
|
20918
|
100
|
|
|
|
57235
|
my $param = $self->params->has($name) ? $self->params->get($name) : undef; |
2045
|
|
|
|
|
|
|
|
2046
|
|
|
|
|
|
|
# execute the directive routine associated with the event |
2047
|
20918
|
|
|
|
|
74748
|
$routine->($directive, $self, $field, $param); |
2048
|
|
|
|
|
|
|
|
2049
|
|
|
|
|
|
|
} |
2050
|
|
|
|
|
|
|
|
2051
|
2618
|
|
|
|
|
15223
|
return $self; |
2052
|
|
|
|
|
|
|
|
2053
|
|
|
|
|
|
|
} |
2054
|
|
|
|
|
|
|
|
2055
|
|
|
|
|
|
|
sub unflatten_params { |
2056
|
|
|
|
|
|
|
|
2057
|
1
|
|
|
1
|
0
|
3
|
my ($self) = @_; |
2058
|
|
|
|
|
|
|
|
2059
|
1
|
|
50
|
|
|
6
|
return $self->params->unflatten->hash || {}; |
2060
|
|
|
|
|
|
|
|
2061
|
|
|
|
|
|
|
} |
2062
|
|
|
|
|
|
|
|
2063
|
|
|
|
|
|
|
|
2064
|
0
|
|
|
0
|
0
|
0
|
sub has_valid { goto &validate } sub validates { goto &validate } sub validate { |
|
0
|
|
|
0
|
0
|
0
|
|
2065
|
|
|
|
|
|
|
|
2066
|
406
|
|
|
406
|
1
|
1294
|
my ($self, $context, @fields) = @_; |
2067
|
|
|
|
|
|
|
|
2068
|
|
|
|
|
|
|
confess |
2069
|
|
|
|
|
|
|
|
2070
|
|
|
|
|
|
|
"Context object ($self->{package} class instance) required ". |
2071
|
406
|
50
|
|
|
|
1609
|
"to perform validation" unless $self->{package} eq ref $context |
2072
|
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
|
; |
2074
|
|
|
|
|
|
|
|
2075
|
|
|
|
|
|
|
# normalize/sanitize |
2076
|
|
|
|
|
|
|
|
2077
|
406
|
|
|
|
|
1291
|
$self->normalize($context); |
2078
|
|
|
|
|
|
|
|
2079
|
|
|
|
|
|
|
# create alias map manually if requested |
2080
|
|
|
|
|
|
|
# ... extremely-deprecated but it remains for back-compat and nostalgia !!! |
2081
|
|
|
|
|
|
|
|
2082
|
406
|
|
|
|
|
622
|
my $alias_map; |
2083
|
|
|
|
|
|
|
|
2084
|
406
|
100
|
|
|
|
1963
|
if (isa_hashref($fields[0])) { |
2085
|
|
|
|
|
|
|
|
2086
|
1
|
|
|
|
|
2
|
$alias_map = $fields[0]; @fields = (); # blank |
|
1
|
|
|
|
|
2
|
|
2087
|
|
|
|
|
|
|
|
2088
|
1
|
|
|
|
|
2
|
while (my($name, $alias) = each(%{$alias_map})) { |
|
2
|
|
|
|
|
9
|
|
2089
|
|
|
|
|
|
|
|
2090
|
1
|
|
|
|
|
5
|
$self->params->add($alias => $self->params->delete($name)); |
2091
|
|
|
|
|
|
|
|
2092
|
1
|
|
|
|
|
3
|
push @fields, $alias; |
2093
|
|
|
|
|
|
|
|
2094
|
|
|
|
|
|
|
} |
2095
|
|
|
|
|
|
|
|
2096
|
|
|
|
|
|
|
} |
2097
|
|
|
|
|
|
|
|
2098
|
|
|
|
|
|
|
# include queued fields |
2099
|
|
|
|
|
|
|
|
2100
|
406
|
100
|
|
|
|
1102
|
if (@{$self->queued}) { |
|
406
|
|
|
|
|
1363
|
|
2101
|
|
|
|
|
|
|
|
2102
|
36
|
|
|
|
|
60
|
push @fields, @{$self->queued}; |
|
36
|
|
|
|
|
111
|
|
2103
|
|
|
|
|
|
|
|
2104
|
|
|
|
|
|
|
} |
2105
|
|
|
|
|
|
|
|
2106
|
|
|
|
|
|
|
# include fields from field patterns |
2107
|
|
|
|
|
|
|
|
2108
|
406
|
100
|
|
|
|
891
|
@fields = map { isa_regexp($_) ? (grep { $_ } ($self->fields->sort)) : ($_) } |
|
512
|
|
|
|
|
1505
|
|
|
8
|
|
|
|
|
22
|
|
2109
|
|
|
|
|
|
|
@fields; |
2110
|
|
|
|
|
|
|
|
2111
|
|
|
|
|
|
|
# process toggled fields |
2112
|
|
|
|
|
|
|
|
2113
|
406
|
|
|
|
|
999
|
foreach my $field (@fields) { |
2114
|
|
|
|
|
|
|
|
2115
|
518
|
|
|
|
|
1754
|
my ($switch) = $field =~ /^([+-])./; |
2116
|
|
|
|
|
|
|
|
2117
|
518
|
100
|
|
|
|
1536
|
if ($switch) { |
2118
|
|
|
|
|
|
|
|
2119
|
|
|
|
|
|
|
# set field toggle directive |
2120
|
|
|
|
|
|
|
|
2121
|
34
|
|
|
|
|
104
|
$field =~ s/^[+-]//; |
2122
|
|
|
|
|
|
|
|
2123
|
34
|
100
|
|
|
|
119
|
if (my $field = $self->fields->get($field)) { |
2124
|
|
|
|
|
|
|
|
2125
|
32
|
100
|
|
|
|
168
|
$field->toggle(1) if $switch eq '+'; |
2126
|
32
|
100
|
|
|
|
125
|
$field->toggle(0) if $switch eq '-'; |
2127
|
|
|
|
|
|
|
|
2128
|
|
|
|
|
|
|
} |
2129
|
|
|
|
|
|
|
|
2130
|
|
|
|
|
|
|
} |
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
} |
2133
|
|
|
|
|
|
|
|
2134
|
|
|
|
|
|
|
# determine what to validate and how |
2135
|
|
|
|
|
|
|
|
2136
|
406
|
100
|
100
|
|
|
2194
|
if (@fields && $self->params->count) { |
|
|
100
|
66
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
2137
|
|
|
|
|
|
|
# validate all parameters against only the fields explicitly |
2138
|
|
|
|
|
|
|
# requested to be validated |
2139
|
|
|
|
|
|
|
} |
2140
|
|
|
|
|
|
|
|
2141
|
|
|
|
|
|
|
elsif (!@fields && $self->params->count) { |
2142
|
|
|
|
|
|
|
# validate all parameters against all defined fields because no fields |
2143
|
|
|
|
|
|
|
# were explicitly requested to be validated, e.g. not explicitly |
2144
|
|
|
|
|
|
|
# defining fields to be validated effectively allows the parameters |
2145
|
|
|
|
|
|
|
# submitted to dictate what gets validated (may not be dangerous) |
2146
|
78
|
|
|
|
|
262
|
@fields = ($self->params->keys); |
2147
|
|
|
|
|
|
|
} |
2148
|
|
|
|
|
|
|
|
2149
|
|
|
|
|
|
|
elsif (@fields && !$self->params->count) { |
2150
|
|
|
|
|
|
|
# validate fields specified although no parameters were submitted |
2151
|
|
|
|
|
|
|
# will likely pass validation unless fields exist with a *required* |
2152
|
|
|
|
|
|
|
# directive or other validation logic expecting a value |
2153
|
|
|
|
|
|
|
} |
2154
|
|
|
|
|
|
|
|
2155
|
|
|
|
|
|
|
else { |
2156
|
|
|
|
|
|
|
# validate all defined fields although no parameters were submitted |
2157
|
|
|
|
|
|
|
# will likely pass validation unless fields exist with a *required* |
2158
|
|
|
|
|
|
|
# directive or other validation logic expecting a value |
2159
|
0
|
|
|
|
|
0
|
@fields = ($self->fields->keys); |
2160
|
|
|
|
|
|
|
} |
2161
|
|
|
|
|
|
|
|
2162
|
|
|
|
|
|
|
# establish the bypass validation flag |
2163
|
406
|
|
|
|
|
1680
|
$self->stash->{'validation.bypass_event'} = 0; |
2164
|
|
|
|
|
|
|
|
2165
|
|
|
|
|
|
|
# stash the current context object |
2166
|
406
|
|
|
|
|
1132
|
$self->stash->{'validation.context'} = $context; |
2167
|
|
|
|
|
|
|
|
2168
|
|
|
|
|
|
|
# report fields requested that do not exist and are not aliases |
2169
|
406
|
|
|
|
|
1959
|
for my $f (grep {!$self->fields->has($_)} uniq @fields) { |
|
562
|
|
|
|
|
1791
|
|
2170
|
|
|
|
|
|
|
next if grep { |
2171
|
9
|
100
|
|
|
|
37
|
if ($_->has('alias')) { |
|
13
|
100
|
|
|
|
67
|
|
2172
|
|
|
|
|
|
|
my @aliases = isa_arrayref($_->get('alias')) ? |
2173
|
1
|
50
|
|
|
|
7
|
@{$_->get('alias')} : ($_->get('alias')) |
|
1
|
|
|
|
|
4
|
|
2174
|
|
|
|
|
|
|
; |
2175
|
1
|
|
|
|
|
3
|
grep { $f eq $_ } @aliases; |
|
1
|
|
|
|
|
9
|
|
2176
|
|
|
|
|
|
|
} |
2177
|
|
|
|
|
|
|
} |
2178
|
|
|
|
|
|
|
$self->fields->values |
2179
|
|
|
|
|
|
|
; |
2180
|
8
|
|
|
|
|
66
|
$self->pitch_error("Data validation field $f does not exist"); |
2181
|
|
|
|
|
|
|
} |
2182
|
|
|
|
|
|
|
|
2183
|
|
|
|
|
|
|
# stash fields targeted for validation |
2184
|
|
|
|
|
|
|
$self->stash->{'validation.fields'} = |
2185
|
405
|
|
|
|
|
1980
|
[grep {$self->fields->has($_)} uniq @fields] |
|
561
|
|
|
|
|
1823
|
|
2186
|
|
|
|
|
|
|
; |
2187
|
|
|
|
|
|
|
|
2188
|
|
|
|
|
|
|
# execute on_before_validation events |
2189
|
|
|
|
|
|
|
$self->trigger_event('on_before_validation', $_) |
2190
|
405
|
|
|
|
|
1102
|
for @{$self->stash->{'validation.fields'}} |
|
405
|
|
|
|
|
990
|
|
2191
|
|
|
|
|
|
|
; |
2192
|
|
|
|
|
|
|
|
2193
|
|
|
|
|
|
|
# execute on_validate events |
2194
|
405
|
100
|
|
|
|
1216
|
unless ($self->stash->{'validation.bypass_event'}) { |
2195
|
|
|
|
|
|
|
$self->trigger_event('on_validate', $_) |
2196
|
375
|
|
|
|
|
575
|
for @{$self->stash->{'validation.fields'}} |
|
375
|
|
|
|
|
930
|
|
2197
|
|
|
|
|
|
|
; |
2198
|
375
|
|
|
|
|
1508
|
$self->validated(1); |
2199
|
375
|
100
|
|
|
|
1345
|
$self->validated(2) if $self->is_valid; |
2200
|
|
|
|
|
|
|
} |
2201
|
|
|
|
|
|
|
|
2202
|
|
|
|
|
|
|
# execute on_after_validation events |
2203
|
|
|
|
|
|
|
$self->trigger_event('on_after_validation', $_) |
2204
|
405
|
|
|
|
|
735
|
for @{$self->stash->{'validation.fields'}} |
|
405
|
|
|
|
|
1003
|
|
2205
|
|
|
|
|
|
|
; |
2206
|
|
|
|
|
|
|
|
2207
|
|
|
|
|
|
|
# re-establish the bypass validation flag |
2208
|
405
|
|
|
|
|
1188
|
$self->stash->{'validation.bypass_event'} = 0; |
2209
|
|
|
|
|
|
|
|
2210
|
|
|
|
|
|
|
# restore params from alias map manually if requested |
2211
|
|
|
|
|
|
|
# ... extremely-deprecated but it remains for back-compat and nostalgia !!! |
2212
|
|
|
|
|
|
|
|
2213
|
405
|
100
|
|
|
|
1177
|
if ( defined $alias_map ) { |
2214
|
|
|
|
|
|
|
|
2215
|
1
|
|
|
|
|
2
|
while (my($name, $alias) = each(%{$alias_map})) { |
|
2
|
|
|
|
|
8
|
|
2216
|
|
|
|
|
|
|
|
2217
|
1
|
|
|
|
|
4
|
$self->params->add($name => $self->params->delete($alias)); |
2218
|
|
|
|
|
|
|
|
2219
|
|
|
|
|
|
|
} |
2220
|
|
|
|
|
|
|
|
2221
|
|
|
|
|
|
|
} |
2222
|
|
|
|
|
|
|
|
2223
|
405
|
100
|
|
|
|
1225
|
return $self->validated == 2 ? 1 : 0; |
2224
|
|
|
|
|
|
|
|
2225
|
|
|
|
|
|
|
} |
2226
|
|
|
|
|
|
|
|
2227
|
|
|
|
|
|
|
|
2228
|
0
|
|
|
0
|
0
|
0
|
sub document_validates { goto &validate_document } sub validate_document { |
2229
|
|
|
|
|
|
|
|
2230
|
16
|
|
|
16
|
1
|
38
|
my ($self, $context, $ref, $data, $options) = @_; |
2231
|
|
|
|
|
|
|
|
2232
|
16
|
|
|
|
|
28
|
my $name; |
2233
|
|
|
|
|
|
|
|
2234
|
16
|
|
|
|
|
66
|
my $documents = clone $self->documents->hash; |
2235
|
|
|
|
|
|
|
|
2236
|
16
|
|
|
|
|
62
|
my $_fmap = {}; # ad-hoc fields |
2237
|
|
|
|
|
|
|
|
2238
|
16
|
100
|
|
|
|
64
|
if ("HASH" eq ref $ref) { |
2239
|
|
|
|
|
|
|
|
2240
|
1
|
|
|
|
|
50
|
$ref = clone $ref; |
2241
|
|
|
|
|
|
|
|
2242
|
1
|
|
|
|
|
12
|
$name = "DOC" . time() . ($self->documents->count + 1); |
2243
|
|
|
|
|
|
|
|
2244
|
|
|
|
|
|
|
# build document on-the-fly from a hashref |
2245
|
1
|
|
|
|
|
3
|
foreach my $rules (values %{$ref}) { |
|
1
|
|
|
|
|
4
|
|
2246
|
|
|
|
|
|
|
|
2247
|
7
|
50
|
|
|
|
19
|
next unless "HASH" eq ref $rules; |
2248
|
|
|
|
|
|
|
|
2249
|
7
|
|
|
|
|
15
|
my $id = uc "$rules"; |
2250
|
7
|
|
|
|
|
28
|
$id =~ s/\W/_/g; |
2251
|
7
|
|
|
|
|
19
|
$id =~ s/_$//; |
2252
|
|
|
|
|
|
|
|
2253
|
7
|
|
|
|
|
22
|
$self->fields->add($id => $rules); |
2254
|
7
|
|
|
|
|
12
|
$rules = $id; |
2255
|
7
|
|
|
|
|
20
|
$_fmap->{$id} = 1; |
2256
|
|
|
|
|
|
|
|
2257
|
|
|
|
|
|
|
} |
2258
|
|
|
|
|
|
|
|
2259
|
1
|
|
|
|
|
4
|
$documents->{$name} = $ref; |
2260
|
|
|
|
|
|
|
|
2261
|
|
|
|
|
|
|
} |
2262
|
|
|
|
|
|
|
|
2263
|
|
|
|
|
|
|
else { |
2264
|
|
|
|
|
|
|
|
2265
|
15
|
|
|
|
|
32
|
$name = $ref; |
2266
|
|
|
|
|
|
|
|
2267
|
|
|
|
|
|
|
} |
2268
|
|
|
|
|
|
|
|
2269
|
16
|
|
|
|
|
69
|
my $fields = { map { $_ => 1 } ($self->fields->keys) }; |
|
34
|
|
|
|
|
97
|
|
2270
|
|
|
|
|
|
|
|
2271
|
16
|
50
|
|
|
|
79
|
confess "Please supply a registered document name to validate against" |
2272
|
|
|
|
|
|
|
unless $name |
2273
|
|
|
|
|
|
|
; |
2274
|
|
|
|
|
|
|
|
2275
|
|
|
|
|
|
|
confess "The ($name) document is not registered and cannot be validated against" |
2276
|
16
|
50
|
33
|
|
|
89
|
unless $name && exists $documents->{$name} |
2277
|
|
|
|
|
|
|
; |
2278
|
|
|
|
|
|
|
|
2279
|
16
|
|
|
|
|
44
|
my $document = $documents->{$name}; |
2280
|
|
|
|
|
|
|
|
2281
|
|
|
|
|
|
|
confess "The ($name) document does not contain any mappings and cannot ". |
2282
|
16
|
50
|
|
|
|
28
|
"be validated against" unless keys %{$documents} |
|
16
|
|
|
|
|
73
|
|
2283
|
|
|
|
|
|
|
; |
2284
|
|
|
|
|
|
|
|
2285
|
16
|
|
100
|
|
|
78
|
$options ||= {}; |
2286
|
|
|
|
|
|
|
|
2287
|
|
|
|
|
|
|
# handle sub-document references |
2288
|
|
|
|
|
|
|
|
2289
|
16
|
|
|
|
|
28
|
for my $key (keys %{$document}) { |
|
16
|
|
|
|
|
60
|
|
2290
|
|
|
|
|
|
|
|
2291
|
|
|
|
|
|
|
$document->{$key} = $documents->{$document->{$key}} if |
2292
|
|
|
|
|
|
|
$document->{$key} && exists $documents->{$document->{$key}} && |
2293
|
73
|
100
|
66
|
|
|
454
|
! $self->fields->has($document->{$key}) |
|
|
|
66
|
|
|
|
|
2294
|
|
|
|
|
|
|
; |
2295
|
|
|
|
|
|
|
|
2296
|
|
|
|
|
|
|
} |
2297
|
|
|
|
|
|
|
|
2298
|
16
|
|
|
|
|
77
|
$document = flatten $document; |
2299
|
|
|
|
|
|
|
|
2300
|
16
|
|
|
|
|
10161
|
my $signature = clone $document; |
2301
|
|
|
|
|
|
|
|
2302
|
|
|
|
|
|
|
# create document signature |
2303
|
|
|
|
|
|
|
|
2304
|
16
|
|
|
|
|
40
|
for my $key (keys %{$signature}) { |
|
16
|
|
|
|
|
64
|
|
2305
|
|
|
|
|
|
|
|
2306
|
105
|
|
|
|
|
249
|
(my $new = $key) =~ s/\\//g; |
2307
|
|
|
|
|
|
|
|
2308
|
105
|
|
|
|
|
160
|
$new =~ s/\*/???/g; |
2309
|
105
|
|
|
|
|
188
|
$new =~ s/\.@/:0/g; |
2310
|
|
|
|
|
|
|
|
2311
|
105
|
|
|
|
|
203
|
$signature->{$new} = '???'; |
2312
|
|
|
|
|
|
|
|
2313
|
105
|
100
|
|
|
|
308
|
delete $signature->{$key} unless $new eq $key; |
2314
|
|
|
|
|
|
|
|
2315
|
|
|
|
|
|
|
} |
2316
|
|
|
|
|
|
|
|
2317
|
16
|
|
|
|
|
252
|
my $overlay = clone $signature; |
2318
|
|
|
|
|
|
|
|
2319
|
16
|
|
|
|
|
38
|
$_ = undef for values %{$overlay}; |
|
16
|
|
|
|
|
85
|
|
2320
|
|
|
|
|
|
|
|
2321
|
|
|
|
|
|
|
# handle regex expansions |
2322
|
|
|
|
|
|
|
|
2323
|
16
|
|
|
|
|
28
|
for my $key (keys %{$document}) { |
|
16
|
|
|
|
|
52
|
|
2324
|
|
|
|
|
|
|
|
2325
|
105
|
|
|
|
|
176
|
my $value = delete $document->{$key}; |
2326
|
|
|
|
|
|
|
|
2327
|
105
|
|
|
|
|
147
|
my $token; |
2328
|
|
|
|
|
|
|
my $regex; |
2329
|
|
|
|
|
|
|
|
2330
|
105
|
|
|
|
|
126
|
$token = '\.\@'; |
2331
|
105
|
|
|
|
|
135
|
$regex = ':\d+'; |
2332
|
105
|
|
|
|
|
300
|
$key =~ s/$token/$regex/g; |
2333
|
|
|
|
|
|
|
|
2334
|
105
|
|
|
|
|
167
|
$token = '\*'; |
2335
|
105
|
|
|
|
|
132
|
$regex = '[^\.]+'; |
2336
|
105
|
|
|
|
|
212
|
$key =~ s/$token/$regex/g; |
2337
|
|
|
|
|
|
|
|
2338
|
105
|
|
|
|
|
260
|
$document->{$key} = $value; |
2339
|
|
|
|
|
|
|
|
2340
|
|
|
|
|
|
|
} |
2341
|
|
|
|
|
|
|
|
2342
|
16
|
|
|
|
|
52
|
my $_dmap = {}; |
2343
|
16
|
|
|
|
|
45
|
my $_pmap = {}; |
2344
|
16
|
|
|
|
|
40
|
my $_xmap = {}; |
2345
|
|
|
|
|
|
|
|
2346
|
16
|
|
|
|
|
51
|
my $_zata = flatten $data; |
2347
|
16
|
|
|
|
|
12669
|
my $_data = merge $overlay, $_zata; |
2348
|
|
|
|
|
|
|
|
2349
|
|
|
|
|
|
|
# remove overlaid patterns if matching nodes exist |
2350
|
|
|
|
|
|
|
|
2351
|
16
|
|
|
|
|
1368
|
for my $key (keys %{$_data}) { |
|
16
|
|
|
|
|
78
|
|
2352
|
|
|
|
|
|
|
|
2353
|
163
|
100
|
|
|
|
452
|
if ($key =~ /\?{3}/) { |
2354
|
|
|
|
|
|
|
|
2355
|
6
|
|
|
|
|
26
|
(my $regex = $key) =~ s/\?{3}/\\w+/g; |
2356
|
|
|
|
|
|
|
|
2357
|
|
|
|
|
|
|
delete $_data->{$key} |
2358
|
6
|
100
|
|
|
|
12
|
if grep { $_ =~ /$regex/ && $_ ne $key } keys %{$_data}; |
|
82
|
50
|
|
|
|
384
|
|
|
6
|
|
|
|
|
23
|
|
2359
|
|
|
|
|
|
|
|
2360
|
|
|
|
|
|
|
} |
2361
|
|
|
|
|
|
|
|
2362
|
|
|
|
|
|
|
} |
2363
|
|
|
|
|
|
|
|
2364
|
|
|
|
|
|
|
# generate validation rules |
2365
|
|
|
|
|
|
|
|
2366
|
16
|
|
|
|
|
45
|
for my $key (keys %{$_data}) { |
|
16
|
|
|
|
|
62
|
|
2367
|
|
|
|
|
|
|
|
2368
|
157
|
|
|
|
|
216
|
my $point = $key; |
2369
|
157
|
|
|
|
|
627
|
$point =~ s/\W/_/g; |
2370
|
157
|
|
|
|
|
236
|
my $label = $key; |
2371
|
157
|
|
|
|
|
356
|
$label =~ s/\:/./g; |
2372
|
|
|
|
|
|
|
|
2373
|
157
|
|
|
|
|
211
|
my $match = 0; |
2374
|
|
|
|
|
|
|
|
2375
|
157
|
|
|
|
|
192
|
my $switch; |
2376
|
|
|
|
|
|
|
|
2377
|
157
|
|
|
|
|
190
|
for my $regex (keys %{$document}) { |
|
157
|
|
|
|
|
503
|
|
2378
|
|
|
|
|
|
|
|
2379
|
1334
|
50
|
|
|
|
2991
|
if (exists $_data->{$key}) { |
2380
|
|
|
|
|
|
|
|
2381
|
1334
|
|
|
|
|
2104
|
my $field = $document->{$regex}; |
2382
|
|
|
|
|
|
|
|
2383
|
1334
|
100
|
|
|
|
15691
|
if ($key =~ /^$regex$/) { |
2384
|
|
|
|
|
|
|
|
2385
|
115
|
100
|
|
|
|
333
|
$switch = $1 if $field =~ s/^([+-])//; |
2386
|
|
|
|
|
|
|
|
2387
|
115
|
|
|
|
|
295
|
my $config = {label => $label}; |
2388
|
|
|
|
|
|
|
|
2389
|
115
|
50
|
|
|
|
455
|
$config->{mixin} = $self->fields->get($field)->mixin |
2390
|
|
|
|
|
|
|
if $self->fields->get($field)->can('mixin') |
2391
|
|
|
|
|
|
|
; |
2392
|
|
|
|
|
|
|
|
2393
|
115
|
|
|
|
|
366
|
$self->clone_field($field, $point => $config); |
2394
|
|
|
|
|
|
|
|
2395
|
|
|
|
|
|
|
$self->apply_mixin($point => $config->{mixin}) |
2396
|
|
|
|
|
|
|
if $config->{mixin} |
2397
|
115
|
100
|
|
|
|
405
|
; |
2398
|
|
|
|
|
|
|
|
2399
|
115
|
|
|
|
|
234
|
$_dmap->{$key} = 1; |
2400
|
115
|
|
|
|
|
223
|
$_pmap->{$point} = $key; |
2401
|
|
|
|
|
|
|
|
2402
|
115
|
|
|
|
|
719
|
$match = 1; |
2403
|
|
|
|
|
|
|
|
2404
|
|
|
|
|
|
|
} |
2405
|
|
|
|
|
|
|
|
2406
|
|
|
|
|
|
|
} |
2407
|
|
|
|
|
|
|
|
2408
|
|
|
|
|
|
|
} |
2409
|
|
|
|
|
|
|
|
2410
|
157
|
|
|
|
|
452
|
$_xmap->{$point} = $key; |
2411
|
|
|
|
|
|
|
|
2412
|
|
|
|
|
|
|
# register node as a parameter |
2413
|
157
|
100
|
|
|
|
567
|
$self->params->add($point => $_data->{$key}) unless ! $match; |
2414
|
|
|
|
|
|
|
|
2415
|
|
|
|
|
|
|
# queue node and requirement |
2416
|
157
|
100
|
|
|
|
693
|
$self->queue($switch ? "$switch$point" : "$point") unless ! $match; |
|
|
100
|
|
|
|
|
|
2417
|
|
|
|
|
|
|
|
2418
|
|
|
|
|
|
|
# prune unnecessary nodes |
2419
|
157
|
100
|
100
|
|
|
954
|
delete $_data->{$key} if $options->{prune} && ! $match; |
2420
|
|
|
|
|
|
|
|
2421
|
|
|
|
|
|
|
} |
2422
|
|
|
|
|
|
|
|
2423
|
|
|
|
|
|
|
# validate |
2424
|
|
|
|
|
|
|
|
2425
|
16
|
|
|
|
|
79
|
$self->validate($context); |
2426
|
|
|
|
|
|
|
|
2427
|
16
|
|
|
|
|
98
|
$self->clear_queue; |
2428
|
|
|
|
|
|
|
|
2429
|
16
|
|
|
|
|
83
|
my @errors = $self->get_errors; |
2430
|
|
|
|
|
|
|
|
2431
|
16
|
|
|
|
|
64
|
for (sort @errors) { |
2432
|
|
|
|
|
|
|
|
2433
|
7
|
|
|
|
|
24
|
my ($message) = $_ =~ /field (\w+) does not exist/; |
2434
|
|
|
|
|
|
|
|
2435
|
7
|
50
|
|
|
|
79
|
next unless $message; |
2436
|
|
|
|
|
|
|
|
2437
|
0
|
|
|
|
|
0
|
$message = $_xmap->{$message}; |
2438
|
|
|
|
|
|
|
|
2439
|
0
|
0
|
|
|
|
0
|
next unless $message; |
2440
|
|
|
|
|
|
|
|
2441
|
0
|
|
|
|
|
0
|
$message =~ s/\W/./g; |
2442
|
|
|
|
|
|
|
|
2443
|
|
|
|
|
|
|
# re-format unknown parameter errors |
2444
|
0
|
|
|
|
|
0
|
$_ = "The parameter $message was not expected and could not be validated"; |
2445
|
|
|
|
|
|
|
|
2446
|
|
|
|
|
|
|
} |
2447
|
|
|
|
|
|
|
|
2448
|
16
|
|
|
|
|
87
|
$_dmap = unflatten $_dmap; |
2449
|
|
|
|
|
|
|
|
2450
|
16
|
|
|
|
|
5873
|
while (my($point, $key) = each(%{$_pmap})) { |
|
131
|
|
|
|
|
467
|
|
2451
|
|
|
|
|
|
|
|
2452
|
115
|
|
|
|
|
323
|
$_data->{$key} = $self->params->get($point); # prepare data |
2453
|
|
|
|
|
|
|
|
2454
|
115
|
100
|
|
|
|
531
|
$self->fields->delete($point) unless $fields->{$point}; # reap clones |
2455
|
|
|
|
|
|
|
|
2456
|
|
|
|
|
|
|
} |
2457
|
|
|
|
|
|
|
|
2458
|
16
|
|
|
|
|
35
|
$self->fields->delete($_) for keys %{$_fmap}; # reap ad-hoc fields |
|
16
|
|
|
|
|
64
|
|
2459
|
|
|
|
|
|
|
|
2460
|
16
|
|
|
|
|
72
|
$self->reset_fields; |
2461
|
|
|
|
|
|
|
|
2462
|
16
|
100
|
|
|
|
71
|
$self->set_errors(@errors) if @errors; # report errors |
2463
|
|
|
|
|
|
|
|
2464
|
16
|
50
|
|
|
|
93
|
$_[3] = unflatten $_data if defined $_[2]; # restore data |
2465
|
|
|
|
|
|
|
|
2466
|
16
|
|
|
|
|
5994
|
return $self->is_valid; |
2467
|
|
|
|
|
|
|
|
2468
|
|
|
|
|
|
|
} |
2469
|
|
|
|
|
|
|
|
2470
|
|
|
|
|
|
|
|
2471
|
0
|
|
|
0
|
0
|
0
|
sub method_validates { goto &validate_method } sub validate_method { |
2472
|
|
|
|
|
|
|
|
2473
|
8
|
|
|
8
|
1
|
24
|
my ($self, $context, $name, @args) = @_; |
2474
|
|
|
|
|
|
|
|
2475
|
|
|
|
|
|
|
confess |
2476
|
|
|
|
|
|
|
"Context object ($self->{package} class instance) required ". |
2477
|
8
|
50
|
|
|
|
36
|
"to perform method validation" unless $self->{package} eq ref $context; |
2478
|
|
|
|
|
|
|
|
2479
|
8
|
50
|
|
|
|
31
|
return 0 unless $name; |
2480
|
|
|
|
|
|
|
|
2481
|
8
|
|
|
|
|
28
|
$self->normalize($context); |
2482
|
8
|
|
|
|
|
36
|
$self->apply_filters('pre'); |
2483
|
|
|
|
|
|
|
|
2484
|
8
|
|
|
|
|
32
|
my $method_spec = $self->methods->{$name}; |
2485
|
8
|
|
|
|
|
19
|
my $input = $method_spec->{input}; |
2486
|
|
|
|
|
|
|
|
2487
|
8
|
50
|
|
|
|
23
|
if ($input) { |
2488
|
|
|
|
|
|
|
|
2489
|
8
|
|
|
|
|
19
|
my $code = $method_spec->{using}; |
2490
|
8
|
|
|
|
|
15
|
my $output = $method_spec->{output}; |
2491
|
|
|
|
|
|
|
|
2492
|
8
|
|
|
|
|
60
|
weaken $method_spec->{$_} for ('using', 'output'); |
2493
|
|
|
|
|
|
|
|
2494
|
8
|
|
|
6
|
|
30
|
$method_spec->{using} = sub { 1 }; |
|
6
|
|
|
|
|
15
|
|
2495
|
8
|
|
|
|
|
17
|
$method_spec->{output} = undef; |
2496
|
|
|
|
|
|
|
|
2497
|
8
|
|
|
|
|
31
|
$context->$name(@args); |
2498
|
|
|
|
|
|
|
|
2499
|
8
|
|
|
|
|
24
|
$method_spec->{using} = $code; |
2500
|
8
|
|
|
|
|
32
|
$method_spec->{output} = $output; |
2501
|
|
|
|
|
|
|
|
2502
|
|
|
|
|
|
|
} |
2503
|
|
|
|
|
|
|
|
2504
|
8
|
100
|
|
|
|
25
|
return $self->is_valid ? 1 : 0; |
2505
|
|
|
|
|
|
|
|
2506
|
|
|
|
|
|
|
} |
2507
|
|
|
|
|
|
|
|
2508
|
|
|
|
|
|
|
|
2509
|
0
|
|
|
0
|
0
|
0
|
sub profile_validates { goto &validate_profile } sub validate_profile { |
2510
|
|
|
|
|
|
|
|
2511
|
23
|
|
|
23
|
1
|
66
|
my ($self, $context, $name, @args) = @_; |
2512
|
|
|
|
|
|
|
|
2513
|
|
|
|
|
|
|
confess |
2514
|
|
|
|
|
|
|
"Context object ($self->{package} class instance) required ". |
2515
|
23
|
50
|
|
|
|
105
|
"to perform profile validation" unless $self->{package} eq ref $context |
2516
|
|
|
|
|
|
|
; |
2517
|
|
|
|
|
|
|
|
2518
|
23
|
50
|
|
|
|
64
|
return 0 unless $name; |
2519
|
|
|
|
|
|
|
|
2520
|
23
|
|
|
|
|
83
|
$self->normalize($context); |
2521
|
23
|
|
|
|
|
89
|
$self->apply_filters('pre'); |
2522
|
|
|
|
|
|
|
|
2523
|
23
|
50
|
|
|
|
81
|
if (isa_coderef($self->profiles->{$name})) { |
2524
|
|
|
|
|
|
|
|
2525
|
23
|
|
|
|
|
81
|
return $self->profiles->{$name}->($context, @args); |
2526
|
|
|
|
|
|
|
|
2527
|
|
|
|
|
|
|
} |
2528
|
|
|
|
|
|
|
|
2529
|
0
|
|
|
|
|
|
return 0; |
2530
|
|
|
|
|
|
|
|
2531
|
|
|
|
|
|
|
} |
2532
|
|
|
|
|
|
|
|
2533
|
|
|
|
|
|
|
1; |
2534
|
|
|
|
|
|
|
|
2535
|
|
|
|
|
|
|
__END__ |