lib/DX/DependencyMap.pm

   1 package DX::DependencyMap;
   2
   3 use DX::Utils qw(CONTENTS_OF INDICES_OF);
   4 use DX::Class;
   5
   6 # { x => [ { y => [ ...
   7 # my $targ = $root; $targ = $targ->[0]{$_[0]} for @path
   8 # my $deps = $targ->[$${$dep_type}];
   9
  10 has deps => (is => 'ro', isa => DependencyTree, required => 1);
  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   };
  26   my $new_deps = $self->_merge_deps_for(
  27     $self->deps, $for_id, map @{$_}[1..$#$_], @expanded
  28   );
  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(
  40     $new_deps, $_, map @{$_}[1..$#$_], @{$new_revdeps{$_}}
  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) {
  69     assert_DependencySpec $mangle_this;
  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 {
  82   my ($self, $dep_groups) = @_;
  83   my @exp;
  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;
  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
 143 sub dependencies_for { $_[0]->revdeps->{$_[1]} }
 144
 145 1;