File Coverage

blib/lib/MooX/Role/DependsOn.pm
Criterion Covered Total %
statement 61 61 100.0
branch 24 26 92.3
condition 8 10 80.0
subroutine 11 11 100.0
pod 2 2 100.0
total 106 110 96.3


line stmt bran cond sub pod time code
1             package MooX::Role::DependsOn;
2             $MooX::Role::DependsOn::VERSION = '1.001001';
3 1     1   11016 use strictures 2;
  1         1087  
  1         41  
4 1     1   143 no warnings 'recursion';
  1         2  
  1         20  
5              
6 1     1   3 use Carp;
  1         1  
  1         59  
7 1     1   4 use Scalar::Util 'blessed', 'reftype';
  1         1  
  1         53  
8              
9 1     1   420 use List::Objects::WithUtils;
  1         610  
  1         5  
10 1     1   48852 use List::Objects::Types -all;
  1         65442  
  1         11  
11              
12 1     1   3437 use Types::Standard -types;
  1         1  
  1         6  
13              
14              
15 1     1   2324 use Moo::Role;
  1         1  
  1         7  
16              
17             has dependency_tag => (
18             is => 'rw',
19             default => sub { my ($self) = @_; "$self" },
20             );
21              
22             has __depends_on => (
23             init_arg => 'depends_on',
24             lazy => 1,
25             is => 'ro',
26             isa => TypedArray[ ConsumerOf['MooX::Role::DependsOn'] ],
27             coerce => 1,
28             default => sub { array_of ConsumerOf['MooX::Role::DependsOn'] },
29             handles => +{
30             clear_dependencies => 'clear',
31             has_dependencies => 'has_any',
32             },
33             );
34              
35             sub depends_on {
36 28     28 1 3753 my ($self, @nodes) = @_;
37 28 100       47 return @{ $self->__depends_on } unless @nodes;
  24         45  
38 4         10 $self->__depends_on->push(@nodes)
39             }
40              
41             sub __resolve_deps {
42 23     23   22 my ($self, $params) = @_;
43              
44 23         19 my $node = $params->{node};
45 23         17 my $resolved = $params->{resolved};
46 23   100     53 my $skip = $params->{skip} ||= +{};
47 23   100     46 my $unresolved = $params->{unresolved} ||= +{};
48              
49 23         33 my $item = $node->dependency_tag;
50              
51 23         34 $unresolved->{$item} = 1;
52              
53 23         25 DEP: for my $edge ($node->depends_on) {
54 27         591 my $depitem = $edge->dependency_tag;
55 27 100       50 next DEP if exists $skip->{$depitem};
56 21 100       31 if (exists $unresolved->{$depitem}) {
57 3 100       9 if (my $cb = $params->{circular_dep_callback}) {
58             # Pass full state for scary munging:
59 2         7 my $state = hash(
60             node => $node,
61             edge => $edge,
62             resolved_array => $resolved,
63             unresolved_hash => $unresolved,
64             skip_hash => $skip
65             )->inflate;
66 2 100       131 next DEP if $self->$cb( $state )
67             }
68 2         1202 die "Circular dependency detected: $item -> $depitem\n"
69             }
70             __resolve_deps( $self,
71             +{
72             node => $edge,
73             skip => $skip,
74            
75             resolved => $resolved,
76             unresolved => $unresolved,
77              
78             resolved_callback => $params->{resolved_callback},
79             circular_dep_callback => $params->{circular_dep_callback},
80             }
81             )
82 18         75 }
83              
84 15         786 push @$resolved, $node;
85 15         27 $skip->{$item} = delete $unresolved->{$item};
86              
87 15 100       27 if (my $cb = $params->{resolved_callback}) {
88 5         13 my $state = hash(
89             node => $node,
90             resolved_array => $resolved,
91             unresolved_hash => $unresolved,
92             skip_hash => $skip
93             )->inflate;
94 5         1166 $self->$cb( $state );
95             }
96              
97             ()
98 15         6876 }
99              
100             sub dependency_schedule {
101 7     7 1 4594 my ($self, %params) = @_;
102              
103             confess
104             "'callback' is deprecated, see the documentation for 'resolved_callback'"
105 7 50       19 if $params{callback};
106              
107 7         7 my $cb;
108 7 100       15 if ($cb = $params{resolved_callback}) {
109 3 100 100     257 confess "Expected 'resolved_callback' param to be a coderef"
110             unless ref $cb and reftype $cb eq 'CODE';
111             }
112              
113 5         5 my $circ_cb;
114 5 100       8 if ($circ_cb = $params{circular_dep_callback}) {
115 2 50 33     16 confess "Expected 'circular_dep_callback' param to be a coderef"
116             unless ref $circ_cb and reftype $circ_cb eq 'CODE';
117             }
118              
119 5         5 my $resolved = [];
120 5 100       24 $self->__resolve_deps(
    100          
121             +{
122             node => $self,
123             resolved => $resolved,
124             ( defined $cb ? (resolved_callback => $cb) : () ),
125             ( defined $circ_cb ? (circular_dep_callback => $circ_cb) : () ),
126             },
127             );
128              
129 3         14 @$resolved
130             }
131              
132              
133             1;
134              
135             =pod
136              
137             =head1 NAME
138              
139             MooX::Role::DependsOn - Add a dependency tree to your cows
140              
141             =head1 SYNOPSIS
142              
143             package Task;
144             use Moo;
145             with 'MooX::Role::DependsOn';
146              
147             sub execute {
148             my ($self) = @_;
149             # ... do stuff ...
150             }
151              
152             package main;
153             # Create some objects that consume MooX::Role::DependsOn:
154             my $job = {};
155             for my $jobname (qw/ A B C D E /) {
156             $job->{$jobname} = Task->new
157             }
158              
159             # Add some dependencies:
160             # A depends on B, D:
161             $job->{A}->depends_on( $job->{B}, $job->{D} );
162             # B depends on C, E:
163             $job->{B}->depends_on( $job->{C}, $job->{E} );
164             # C depends on D, E:
165             $job->{C}->depends_on( $job->{D}, $job->{E} );
166              
167             # Resolve dependencies (recursively) for an object:
168             my @ordered = $job->{A}->dependency_schedule;
169             # Scheduled as ( D, E, C, B, A ):
170             for my $obj (@ordered) {
171             $obj->execute;
172             }
173              
174             =head1 DESCRIPTION
175              
176             A L that adds a dependency graph builder to your class; objects
177             with this role applied can (recursively) depend on other objects (that also
178             consume this role) to produce an ordered list of dependencies.
179              
180             This is useful for applications such as job ordering (see the SYNOPSIS) and resolving
181             software dependencies.
182              
183             =head2 Attributes
184              
185             =head3 dependency_tag
186              
187             An object's B is used to perform the actual resolution; the
188             tag should be a stringifiable value that is unique within the tree.
189              
190             Defaults to the stringified value of C<$self>.
191              
192             =head2 Methods
193              
194             =head3 depends_on
195              
196             If passed no arguments, returns the current direct dependencies of the object
197             as an unordered list.
198              
199             If passed objects that are L consumers (or used as an
200             attribute with an ARRAY-type value during object construction), the objects
201             are pushed to the current dependency list.
202              
203             =head3 clear_dependencies
204              
205             Clears the current dependency list for this object.
206              
207             =head3 has_dependencies
208              
209             Returns boolean true if the object has dependencies.
210              
211             =head3 dependency_schedule
212              
213             This method recursively resolves dependencies and returns an ordered
214             'schedule' (as a list of objects). See the L for an example.
215              
216             =head4 Resolution callbacks
217              
218             A callback can be passed in; for each successful resolution, the callback will
219             be invoked against the root object we started with:
220              
221             my @ordered = $startnode->dependency_schedule(
222             resolved_callback => sub {
223             my (undef, $state) = @_;
224             # ...
225             },
226             );
227              
228             The C<$state> object passed in is a simple struct-like object providing access
229             to the current resolution state. This consists primarily of a set of lists
230             (represented as hashes for performance reasons).
231              
232             (These are references to the actual in-use state; it's possible to do scary
233             things to the tree from here -- in which case it is presumed that you have read
234             and understand the source code.)
235              
236             The object provides the following accessors:
237              
238             =over
239              
240             =item node
241              
242             The node we are currently processing.
243              
244             =item resolved_array
245              
246             The ordered list of successfully resolved nodes, as an ARRAY of the original
247             objects; this is the ARRAY used to produce the final list produced by
248             L.
249              
250             =item unresolved_hash
251              
252             The list of 'seen but not yet resolved' nodes, as a HASH keyed on
253             L.
254              
255             =item skip_hash
256              
257             The list of nodes to skip (because they have already been seen), as a HASH
258             keyed on L.
259              
260             =back
261              
262             =head4 Circular dependency callbacks
263              
264             An exception is thrown if circular dependencies are detected; it's possible to
265             override that behavior by providing a B that is invoked
266             against the root object:
267              
268             my @ordered = $startnode->dependency_schedule(
269             circular_dep_callback => sub {
270             my (undef, $state) = @_;
271             # ...
272             },
273             );
274              
275             If the callback returns true, resolution continues at the next node; otherwise
276             an exception is thrown after callback execution.
277              
278             The C<$state> object has the same accessors as resolution callbacks (described
279             above), plus the following:
280              
281             =over
282              
283             =item edge
284              
285             The dependency node we are attempting to examine.
286              
287             =back
288              
289             =head1 AUTHOR
290              
291             Jon Portnoy
292              
293             Licensed under the same terms as Perl.
294              
295             =cut
296              
297             # vim: ts=2 sw=2 et sts=2 ft=perl