Commit | Line | Data |
efad53c4 |
1 | package DX::DependencyMap; |
2 | |
3 | use DX::Utils qw(CONTENTS_OF INDICES_OF); |
3e465d5d |
4 | use DX::Class; |
efad53c4 |
5 | |
6 | # { x => [ { y => [ ... |
7 | # my $targ = $root; $targ = $targ->[0]{$_[0]} for @path |
8 | # my $deps = $targ->[$${$dep_type}]; |
9 | |
3e465d5d |
10 | has deps => (is => 'ro', isa => DependencyTree, required => 1); |
efad53c4 |
11 | |
12 | has revdeps => (is => 'ro', required => 1); |
13 | |
14 | sub new_empty { |
15 | my ($class) = @_; |
16 | $class->new(deps => {}, revdeps => {}); |
17 | } |
18 | |
19 | sub with_entry_for { |
20 | my ($self, $for_id, $deps_for) = @_; |
21 | my @expanded = $self->_expand_deps($deps_for); |
22 | my $new_revdeps = { |
23 | %{$self->revdeps}, |
24 | $for_id => \@expanded, |
25 | }; |
4016201b |
26 | my $new_deps = $self->_merge_deps_for( |
27 | $self->deps, $for_id, map @{$_}[1..$#$_], @expanded |
28 | ); |
efad53c4 |
29 | ref($self)->new( |
30 | deps => $new_deps, |
31 | revdeps => $new_revdeps |
32 | ); |
33 | } |
34 | |
35 | sub without_entries_for { |
36 | my ($self, @for_ids) = @_; |
37 | my %new_revdeps = %{$self->revdeps}; |
38 | my $new_deps = $self->deps; |
39 | $new_deps = $self->_unmerge_deps_for( |
4016201b |
40 | $new_deps, $_, map @{$_}[1..$#$_], @{$new_revdeps{$_}} |
efad53c4 |
41 | ) for @for_ids; |
42 | delete @new_revdeps{@for_ids}; |
43 | ref($self)->new( |
44 | deps => $new_deps, |
45 | revdeps => \%new_revdeps |
46 | ); |
47 | } |
48 | |
49 | sub _merge_deps_for { |
50 | my ($self, $deps, $for_id, @merge_these) = @_; |
51 | $self->_mangle_deps($deps, sub { |
52 | +{ %{$_[0]}, $for_id => 1 }; |
53 | }, @merge_these); |
54 | } |
55 | |
56 | sub _unmerge_deps_for { |
57 | my ($self, $deps, $for_id, @unmerge_these) = @_; |
58 | $self->_mangle_deps($deps, sub { |
59 | my %for_ids = %{$_[0]}; |
60 | delete $for_ids{$for_id}; |
61 | \%for_ids; |
62 | }, @unmerge_these); |
63 | } |
64 | |
65 | sub _mangle_deps { |
66 | my ($self, $deps, $mangler, @to_mangle) = @_; |
67 | my $root = [ $deps ]; |
68 | foreach my $mangle_this (@to_mangle) { |
3e465d5d |
69 | assert_DependencySpec $mangle_this; |
efad53c4 |
70 | my ($type, @path) = @$mangle_this; |
71 | my $targ = $root; |
72 | foreach my $part (@path) { |
73 | my $sub = $targ->[0] = { %{$targ->[0]||{}} }; |
74 | $targ = $sub->{$part} = [ @{$sub->{$part}||[]} ]; |
75 | } |
76 | $targ->[$$$type] = $mangler->($targ->[$$$type]||{}); |
77 | } |
78 | return $root->[0]; |
79 | } |
80 | |
81 | sub _expand_deps { |
4016201b |
82 | my ($self, $dep_groups) = @_; |
efad53c4 |
83 | my @exp; |
4016201b |
84 | assert_DependencyGroupList $dep_groups; |
85 | map { |
86 | my ($on, @deps) = @$_; |
87 | my @exp; |
88 | DEP: foreach my $dep (@deps) { |
89 | my ($type, @path) = @$dep; |
90 | push @exp, [ |
91 | $type, |
92 | map { ref() ? @{$_->identity_path or next DEP} : $_ } @path |
93 | ]; |
94 | } |
95 | (@exp ? [ $on, @exp ] : ()); |
96 | } @$dep_groups; |
efad53c4 |
97 | } |
98 | |
99 | sub _dependents_of { |
100 | my ($self, $event) = @_; |
101 | my ($type, @path) = @$event; |
102 | my $root = [ $self->deps ]; |
103 | my $targ = $root; |
104 | my $last = pop @path; |
105 | my @dep_sets; |
106 | foreach my $part (@path) { |
107 | $targ = $targ->[0]{$part}; |
108 | # set/add/remove x.y or x.y.z affects contents of x |
109 | push @dep_sets, $targ->[$${+CONTENTS_OF}]; |
110 | } |
111 | if ($$$type) { |
112 | # add/remove x.y affects indices of x |
113 | push @dep_sets, $targ->[$${+INDICES_OF}]; |
114 | } |
115 | $targ = $targ->[0]{$last}; |
116 | { |
117 | # add/remove x affects existence of x |
118 | # set/add/remove x affects everything else too |
119 | push @dep_sets, @{$targ}[map $$$_, @$$type]; |
120 | } |
121 | # set/add/remove x affects all dependencies on x.y, x.y.z etc. |
122 | my @q = values %{$targ->[0]}; |
123 | while (my $el = shift @q) { |
124 | my ($el_kids, @el_deps) = @$el; |
125 | push @dep_sets, @el_deps; |
126 | push @q, values %{$el_kids||{}}; |
127 | } |
128 | return keys %{{ |
129 | map +($_ => 1), map keys %$_, grep defined, @dep_sets |
130 | }}; |
131 | } |
132 | |
133 | sub but_expire_dependents_of { |
134 | my ($self, @events) = @_; |
135 | my @expired = keys %{{ |
136 | map +($_ => 1), map $self->_dependents_of($_), @events |
137 | }}; |
138 | # Didn't expire anything? Don't clone self |
139 | return $self unless @expired; |
140 | ($self->without_entries_for(@expired), @expired); |
141 | } |
142 | |
3e465d5d |
143 | sub dependencies_for { $_[0]->revdeps->{$_[1]} } |
144 | |
efad53c4 |
145 | 1; |