line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ABSTRACT: Validation::Class Core Directives Registry |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Validation::Class::Directives; |
4
|
|
|
|
|
|
|
|
5
|
108
|
|
|
108
|
|
618
|
use strict; |
|
108
|
|
|
|
|
1264
|
|
|
108
|
|
|
|
|
3790
|
|
6
|
108
|
|
|
108
|
|
1763
|
use warnings; |
|
108
|
|
|
|
|
1389
|
|
|
108
|
|
|
|
|
3953
|
|
7
|
|
|
|
|
|
|
|
8
|
108
|
|
|
108
|
|
2755
|
use base 'Validation::Class::Mapping'; |
|
108
|
|
|
|
|
2355
|
|
|
108
|
|
|
|
|
72838
|
|
9
|
|
|
|
|
|
|
|
10
|
108
|
|
|
108
|
|
700
|
use Validation::Class::Util '!has'; |
|
108
|
|
|
|
|
300
|
|
|
108
|
|
|
|
|
750
|
|
11
|
|
|
|
|
|
|
|
12
|
108
|
|
|
108
|
|
94437
|
use List::MoreUtils 'first_index'; |
|
108
|
|
|
|
|
1323356
|
|
|
108
|
|
|
|
|
906
|
|
13
|
108
|
|
|
108
|
|
82600
|
use Module::Find 'usesub'; |
|
108
|
|
|
|
|
17217
|
|
|
108
|
|
|
|
|
7185
|
|
14
|
108
|
|
|
108
|
|
638
|
use Carp 'confess'; |
|
108
|
|
|
|
|
217
|
|
|
108
|
|
|
|
|
4736
|
|
15
|
|
|
|
|
|
|
|
16
|
108
|
|
|
108
|
|
568
|
use List::MoreUtils; |
|
108
|
|
|
|
|
202
|
|
|
108
|
|
|
|
|
496
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $_registry = {}; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
foreach my $module (usesub 'Validation::Class::Directive') { |
21
|
|
|
|
|
|
|
$_registry->{$module} = $module->new |
22
|
|
|
|
|
|
|
if $module->isa('Validation::Class::Directive') |
23
|
|
|
|
|
|
|
; |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
our $VERSION = '7.900057'; # VERSION |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub new { |
30
|
|
|
|
|
|
|
|
31
|
3150
|
|
|
3150
|
1
|
5339
|
my $class = shift; |
32
|
|
|
|
|
|
|
|
33
|
3150
|
|
|
|
|
10539
|
my $arguments = $class->build_args(@_); |
34
|
|
|
|
|
|
|
|
35
|
3150
|
100
|
|
|
|
6925
|
$arguments = $_registry unless keys %{$arguments}; |
|
3150
|
|
|
|
|
10375
|
|
36
|
|
|
|
|
|
|
|
37
|
3150
|
|
|
|
|
7162
|
my $self = bless {}, $class; |
38
|
|
|
|
|
|
|
|
39
|
3150
|
|
|
|
|
8218
|
$self->add($arguments); |
40
|
|
|
|
|
|
|
|
41
|
3150
|
|
|
|
|
12743
|
return $self; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub add { |
46
|
|
|
|
|
|
|
|
47
|
3150
|
|
|
3150
|
1
|
4257
|
my $self = shift; |
48
|
|
|
|
|
|
|
|
49
|
3150
|
|
|
|
|
9236
|
my $arguments = $self->build_args(@_); |
50
|
|
|
|
|
|
|
|
51
|
3150
|
|
|
|
|
8533
|
while (my ($key, $value) = each %{$arguments}) { |
|
68473
|
|
|
|
|
205991
|
|
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# never overwrite |
54
|
65323
|
50
|
|
|
|
149357
|
unless (defined $self->{$key}) { |
55
|
|
|
|
|
|
|
# is it a direct directive? |
56
|
65323
|
100
|
|
|
|
224376
|
if ("Validation::Class::Directive" eq ref $value) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
57
|
1
|
|
|
|
|
3
|
$self->{$key} = $value; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
# is it a directive sub-class |
60
|
|
|
|
|
|
|
elsif (isa_classref($value)) { |
61
|
65322
|
50
|
|
|
|
236591
|
if ($value->isa("Validation::Class::Directive")) { |
62
|
65322
|
|
|
|
|
191978
|
$self->{$value->name} = $value; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
# is it a hashref |
66
|
|
|
|
|
|
|
elsif (isa_hashref($value)) { |
67
|
0
|
|
|
|
|
0
|
$self->{$key} = Validation::Class::Directive->new($value); |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
3150
|
|
|
|
|
13125
|
return $self; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub resolve_dependencies { |
78
|
|
|
|
|
|
|
|
79
|
2618
|
|
|
2618
|
0
|
4256
|
my ($self, $type) = @_; |
80
|
|
|
|
|
|
|
|
81
|
2618
|
|
50
|
|
|
5808
|
$type ||= 'validation'; |
82
|
|
|
|
|
|
|
|
83
|
2618
|
|
|
|
|
4028
|
my $dependencies = {}; |
84
|
|
|
|
|
|
|
|
85
|
2618
|
|
|
|
|
8347
|
foreach my $key ($self->keys) { |
86
|
|
|
|
|
|
|
|
87
|
40851
|
|
|
|
|
108324
|
my $class = $self->get($key); |
88
|
40851
|
|
|
|
|
109578
|
my $name = $class->name; |
89
|
40851
|
|
|
|
|
123834
|
my $dependents = $class->dependencies->{$type}; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
# avoid invalid dependencies by excluding the unknown |
92
|
40851
|
|
|
|
|
53721
|
$dependencies->{$name} = [grep { $self->has($_) } @{$dependents}]; |
|
109517
|
|
|
|
|
272376
|
|
|
40851
|
|
|
|
|
102612
|
|
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
2618
|
|
|
|
|
14806
|
my @ordered; |
97
|
|
|
|
|
|
|
my %found; |
98
|
0
|
|
|
|
|
0
|
my %track; |
99
|
|
|
|
|
|
|
|
100
|
2618
|
|
|
|
|
14637
|
my @pending = keys %$dependencies; |
101
|
2618
|
|
|
|
|
6186
|
my $limit = scalar(keys %$dependencies); |
102
|
2618
|
|
|
|
|
7643
|
$limit += scalar(@{$_}) for values %$dependencies; |
|
40851
|
|
|
|
|
63534
|
|
103
|
|
|
|
|
|
|
|
104
|
2618
|
|
|
|
|
6267
|
while (@pending) { |
105
|
|
|
|
|
|
|
|
106
|
52701
|
|
|
|
|
71191
|
my $k = shift @pending; |
107
|
|
|
|
|
|
|
|
108
|
52701
|
50
|
|
|
|
63880
|
if (grep { $_ eq $k } @{$dependencies->{$k}}) { |
|
160708
|
100
|
|
|
|
279533
|
|
|
52701
|
|
|
|
|
105694
|
|
109
|
|
|
|
|
|
|
|
110
|
0
|
|
|
|
|
0
|
confess sprintf 'Direct circular dependency on event %s: %s -> %s', |
111
|
|
|
|
|
|
|
$type, $k, $k; |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
160708
|
|
|
|
|
305582
|
elsif (grep { ! exists $found{$_} } @{$dependencies->{$k}}) { |
|
52701
|
|
|
|
|
98192
|
|
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
confess sprintf 'Invalid dependency on event %s: %s -> %s', |
118
|
0
|
|
|
|
|
0
|
$type, $k, join(',', @{$dependencies->{$k}}) |
119
|
11850
|
50
|
|
|
|
13440
|
if grep { ! exists $dependencies->{$_} } @{$dependencies->{$k}}; |
|
103808
|
|
|
|
|
200287
|
|
|
11850
|
|
|
|
|
20682
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
confess |
122
|
|
|
|
|
|
|
sprintf 'Indirect circular dependency on event %s: %s -> %s ', |
123
|
0
|
|
|
|
|
0
|
$type, $k, join(',', @{$dependencies->{$k}}) |
124
|
11850
|
50
|
66
|
|
|
39395
|
if $track{$k} && $track{$k} > $limit; # allowed circular iterations |
125
|
|
|
|
|
|
|
|
126
|
11850
|
50
|
|
|
|
47812
|
$track{$k}++ if push @pending, $k; |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
else { |
131
|
|
|
|
|
|
|
|
132
|
40851
|
|
|
|
|
58334
|
$found{$k} = 1; |
133
|
40851
|
|
|
|
|
105129
|
push @ordered, $k; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
2618
|
|
|
|
|
9627
|
my @list = reverse @ordered; |
140
|
|
|
|
|
|
|
|
141
|
2618
|
|
|
|
|
9601
|
foreach my $x (keys %$dependencies) { |
142
|
|
|
|
|
|
|
|
143
|
40851
|
|
|
|
|
44304
|
foreach my $y (@{$dependencies->{$x}}) { |
|
40851
|
|
|
|
|
80422
|
|
144
|
|
|
|
|
|
|
|
145
|
56900
|
|
|
121174
|
|
199144
|
my $a = first_index { $_ eq $x } @list; |
|
121174
|
|
|
|
|
164958
|
|
146
|
56900
|
|
|
1082440
|
|
228408
|
my $b = first_index { $_ eq $y } @list; |
|
1082440
|
|
|
|
|
1188166
|
|
147
|
|
|
|
|
|
|
|
148
|
56900
|
50
|
|
|
|
181914
|
confess sprintf |
149
|
|
|
|
|
|
|
'Broken dependency chain; Faulty ordering on '. |
150
|
|
|
|
|
|
|
'event %s: %s before %s', $type, $x, $y |
151
|
|
|
|
|
|
|
if $a > $b |
152
|
|
|
|
|
|
|
; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
2618
|
|
|
|
|
37345
|
return (@ordered); |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
1; |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
__END__ |