lib/DX/DependencyMap.pm

   1 package DX::DependencyMap;
   2
   3 use DX::Utils qw(CONTENTS_OF INDICES_OF);
   4 use Moo;
   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', 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($self->deps, $for_id, @expanded);
  27   ref($self)->new(
  28     deps => $new_deps,
  29     revdeps => $new_revdeps
  30   );
  31 }
  32
  33 sub without_entries_for {
  34   my ($self, @for_ids) = @_;
  35   my %new_revdeps = %{$self->revdeps};
  36   my $new_deps = $self->deps;
  37   $new_deps = $self->_unmerge_deps_for(
  38     $new_deps, $_, @{$new_revdeps{$_}}
  39   ) for @for_ids;
  40   delete @new_revdeps{@for_ids};
  41   ref($self)->new(
  42     deps => $new_deps,
  43     revdeps => \%new_revdeps
  44   );
  45 }
  46
  47 sub _merge_deps_for {
  48   my ($self, $deps, $for_id, @merge_these) = @_;
  49   $self->_mangle_deps($deps, sub {
  50     +{ %{$_[0]}, $for_id => 1 };
  51   }, @merge_these);
  52 }
  53
  54 sub _unmerge_deps_for {
  55   my ($self, $deps, $for_id, @unmerge_these) = @_;
  56   $self->_mangle_deps($deps, sub {
  57     my %for_ids = %{$_[0]};
  58     delete $for_ids{$for_id};
  59     \%for_ids;
  60   }, @unmerge_these);
  61 }
  62
  63 sub _mangle_deps {
  64   my ($self, $deps, $mangler, @to_mangle) = @_;
  65   my $root = [ $deps ];
  66   foreach my $mangle_this (@to_mangle) {
  67     my ($type, @path) = @$mangle_this;
  68     my $targ = $root;
  69     foreach my $part (@path) {
  70       my $sub = $targ->[0] = { %{$targ->[0]||{}} };
  71       $targ = $sub->{$part} = [ @{$sub->{$part}||[]} ];
  72     }
  73     $targ->[$$$type] = $mangler->($targ->[$$$type]||{});
  74   }
  75   return $root->[0];
  76 }
  77
  78 sub _expand_deps {
  79   my ($self, $deps) = @_;
  80   my @exp;
  81   DEP: foreach my $dep (@$deps) {
  82     my ($type, @path) = @$dep;
  83     push @exp, [
  84       $type,
  85       map { ref() ? @{$_->identity_path or next DEP} : $_ } @path
  86     ];
  87   }
  88   return @exp;
  89 }
  90
  91 sub _dependents_of {
  92   my ($self, $event) = @_;
  93   my ($type, @path) = @$event;
  94   my $root = [ $self->deps ];
  95   my $targ = $root;
  96   my $last = pop @path;
  97   my @dep_sets;
  98   foreach my $part (@path) {
  99     $targ = $targ->[0]{$part};
 100     # set/add/remove x.y or x.y.z affects contents of x
 101     push @dep_sets, $targ->[$${+CONTENTS_OF}];
 102   }
 103   if ($$$type) {
 104     # add/remove x.y affects indices of x
 105     push @dep_sets, $targ->[$${+INDICES_OF}];
 106   }
 107   $targ = $targ->[0]{$last};
 108   {
 109     # add/remove x affects existence of x
 110     # set/add/remove x affects everything else too
 111     push @dep_sets, @{$targ}[map $$$_, @$$type];
 112   }
 113   # set/add/remove x affects all dependencies on x.y, x.y.z etc.
 114   my @q = values %{$targ->[0]};
 115   while (my $el = shift @q) {
 116     my ($el_kids, @el_deps) = @$el;
 117     push @dep_sets, @el_deps;
 118     push @q, values %{$el_kids||{}};
 119   }
 120   return keys %{{
 121     map +($_ => 1), map keys %$_, grep defined, @dep_sets
 122   }};
 123 }
 124
 125 sub but_expire_dependents_of {
 126   my ($self, @events) = @_;
 127   my @expired = keys %{{
 128     map +($_ => 1), map $self->_dependents_of($_), @events
 129   }};
 130   # Didn't expire anything? Don't clone self
 131   return $self unless @expired;
 132   ($self->without_entries_for(@expired), @expired);
 133 }
 134
 135 1;