File Coverage

blib/lib/Validation/Class/Directives.pm
Criterion Covered Total %
statement 80 85 94.1
branch 14 24 58.3
condition 3 5 60.0
subroutine 13 13 100.0
pod 2 3 66.6
total 112 130 86.1


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__