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