lib/graphincludes/graph.pm

   1 # This file is part of the DEPS/graph-includes package
   2 #
   3 # (c) 2005,2006 Yann Dirson <ydirson@altern.org>
   4 # Distributed under version 2 of the GNU GPL.
   5
   6 package graphincludes::graph;
   7 use strict;
   8 use warnings;
   9
  10 use Hash::Util qw(lock_keys);
  11 use Carp qw(croak);
  12 use DEPS::Node;
  13 use DEPS::Edge;
  14
  15 sub new {
  16   my $class = shift;
  17   my $self = {};
  18
  19   $self->{_NODES} = undef;
  20   $self->{_EDGES} = undef;
  21   $self->{_REVEDGES} = undef;
  22
  23   $self->{_DROPCOUNT} = 0;
  24   $self->{_DROPPEDEDGES} = {};
  25   $self->{_DROPPEDREVEDGES} = {};
  26
  27   bless ($self, $class);
  28   lock_keys (%$self);
  29   return $self;
  30 }
  31
  32 sub copy {
  33   my $self = shift;
  34   my %args = @_;
  35
  36   my $class = ref $self;
  37   my %nodes = %{$self->{_NODES}};
  38   my $copy = {
  39               _NODES => \%nodes,
  40               _DROPCOUNT => 0,
  41               _EDGES => {},
  42               _REVEDGES => {},
  43               _DROPPEDEDGES => {},
  44               _DROPPEDREVEDGES => {},
  45              };
  46
  47   bless ($copy, $class);
  48
  49   if (defined $args{deep_copy_edges}) {
  50     foreach my $src ($self->get_edge_origins) {
  51       foreach my $dst ($self->get_dep_names_from($src)) {
  52         $copy->record_edge($src,$dst);
  53       }
  54     }
  55   } else {
  56     # FIXME: copy mode probably too shallow to make any sense ?
  57     my (%edges,%revedges);
  58     %edges = %{$self->{_EDGES}};
  59     %revedges = %{$self->{_REVEDGES}};
  60     $copy->{_EDGES} = \%edges;
  61     $copy->{_REVEDGES} = \%revedges;
  62   }
  63
  64   lock_keys (%$copy);
  65   return $copy;
  66 }
  67
  68 sub set_nodes {
  69   my $self = shift;
  70
  71   # store nodes as a hash indexed by label
  72   my %nodes = map { ($_->{LABEL} => $_) } @_;
  73
  74   $self->{_NODES} = \%nodes;
  75 }
  76 sub set_nodes_from_names {
  77   my $self = shift;
  78   my ($files) = @_;
  79
  80   $self->set_nodes(map { new DEPS::Node($_); } @$files);
  81 }
  82 sub record_node {
  83   my $self = shift;
  84   my ($name) = @_;
  85
  86   # sanity check
  87   croak "node name must not be an object or reference" if ref $name;
  88
  89   $self->{_NODES}{$name} = new DEPS::Node($name)
  90     unless defined $self->{_NODES}{$name};
  91
  92   return $self->{_NODES}{$name};
  93 }
  94
  95 sub add_node {
  96   my $self = shift;
  97   my ($node) = @_;
  98
  99   # sanity checks
 100   unless (ref $node) {
 101     printf STDERR "Non-object: %s\n", $node->dump;
 102     croak "Trying to add a non-object as node";
 103   }
 104   if (defined $self->{_NODES}{$node->{LABEL}}) {
 105     printf STDERR "Already have %s\n", $self->{_NODES}{$node->{LABEL}}->dump;
 106     printf STDERR "Want to add %s\n", $node->dump;
 107     croak "Cannot add another node labelled $node->{LABEL}";
 108   }
 109
 110   $self->{_NODES}{$node->{LABEL}} = $node;
 111 }
 112
 113 sub get_nodes {
 114   my $self = shift;
 115
 116   values %{$self->{_NODES}};
 117 }
 118
 119 sub get_node_from_name {
 120   my $self = shift;
 121   my ($name) = @_;
 122
 123   $self->{_NODES}{$name};
 124 }
 125 sub has_node {
 126   my $self = shift;
 127   my ($name) = @_;
 128
 129   defined get_node_from_name($name);
 130 }
 131
 132 sub record_edge {
 133   my $self = shift;
 134   my ($src, $dst) = @_;
 135
 136 #   if (defined $self->{IGNOREDDEPS}{$src}{$dst}) {
 137 #     print STDERR "ignoring $src -> $dst\n" if $graphincludes::params::debug;
 138 #     $self->{IGNOREDEDGES}{$src}{$dst} =
 139 #       $self->{IGNOREDDEPS}{$src}{$dst};
 140 #   }
 141
 142   # sanity check
 143   croak "edge src name must not be an object or reference" if ref $src;
 144   croak "edge dst name must not be an object or reference" if ref $dst;
 145
 146   unless (defined $self->{_EDGES}{$src}{$dst}) {
 147     # more sanity check
 148     my $srcnode = $self->{_NODES}{$src}
 149       or croak "Source node not found '$src'";
 150     my $dstnode = $self->{_NODES}{$dst}
 151       or croak "Destination node not found '$dst' (source was '$src')";
 152
 153     my $edge = new DEPS::Edge ($srcnode, $dstnode);
 154
 155     $self->{_EDGES}{$src}{$dst} = $self->{_REVEDGES}{$dst}{$src} = $edge;
 156   }
 157
 158   return $self->{_EDGES}{$src}{$dst};
 159 }
 160
 161 sub add_edge {
 162   my $self = shift;
 163   my ($edge) = @_;
 164
 165   # sanity checks
 166   unless (ref $edge) {
 167     printf STDERR "Non-object: %s\n", $edge;
 168     croak "Trying to add a non-object as edge";
 169   }
 170   if ($self->has_edge($edge->{SRC}{LABEL},$edge->{DST}{LABEL})) {
 171     printf STDERR "Already have %s\n", $self->get_edge($edge->{SRC}{LABEL},$edge->{DST}{LABEL})->dump;
 172     printf STDERR "Want to add %s\n", $edge->dump;
 173     croak "Request to add duplicate edge";
 174   }
 175
 176   # do add
 177   $self->{_EDGES}{$edge->{SRC}{LABEL}}{$edge->{DST}{LABEL}} =
 178     $self->{_REVEDGES}{$edge->{DST}{LABEL}}{$edge->{SRC}{LABEL}} = $edge;
 179 }
 180
 181 sub has_children {
 182   my $self = shift;
 183   my ($src) = @_;
 184
 185   # FIXME: not 100% correct - that could be an empty hash
 186   defined $self->{_EDGES}{$src};
 187 }
 188 sub has_parents {
 189   my $self = shift;
 190   my ($dst) = @_;
 191
 192   defined $self->{_REVEDGES}{$dst};
 193 }
 194
 195 sub get_edge {
 196   my $self = shift;
 197   my ($src, $dst) = @_;
 198   return $self->{_EDGES}{$src}{$dst};
 199 }
 200 sub has_edge {
 201   my $self = shift;
 202   my ($src, $dst) = @_;
 203   croak "has_edge: uninitialized src" unless defined $src;
 204   croak "has_edge: uninitialized dst" unless defined $dst;
 205   defined $self->{_EDGES}{$src}{$dst};
 206 }
 207 sub has_path {
 208   my $self = shift;
 209   my ($from, $to, @seen) = @_;  # @seen is a private parameter
 210   return ($from) if $from eq $to;
 211   return () if grep { $_ eq $from } @seen;
 212   return ($from, $to) if $self->has_edge($from,$to); # superfluous ?
 213   foreach my $child ($self->get_dep_names_from($from)) {
 214     if (my @path = $self->has_path($child, $to, (@seen, $from))) {
 215       return ($from, @path);
 216     }
 217   }
 218   return (); # no child (left) to look at
 219 }
 220
 221 sub drop_edge {
 222   my $self = shift;
 223   my ($src, $dst) = @_;
 224
 225   $self->{_DROPPEDEDGES}{$src}{$dst} = $self->{_EDGES}{$src}{$dst};
 226   $self->{_DROPPEDREVEDGES}{$dst}{$src} = $self->{_REVEDGES}{$dst}{$src};
 227   delete $self->{_EDGES}{$src}{$dst};
 228   delete $self->{_REVEDGES}{$dst}{$src};
 229 }
 230
 231 sub get_edge_origins {
 232   my $self = shift;
 233   keys %{$self->{_EDGES}};
 234 }
 235 sub get_edges_from {
 236   my $self = shift;
 237   my ($origin) = @_;
 238   values %{$self->{_EDGES}{$origin}};
 239 }
 240 sub get_dep_names_from {
 241   my $self = shift;
 242   my ($origin) = @_;
 243   keys %{$self->{_EDGES}{$origin}};
 244 }
 245
 246 sub get_edge_weight {
 247   my $self = shift;
 248   my ($src,$dst) = @_;
 249   return $self->get_edge($src,$dst)->weight();
 250 }
 251
 252 sub is_reduction_of {
 253   my $self = shift;
 254   my ($complete) = @_;
 255
 256   print STDERR "Verifying validity of transitive reduction "
 257     if $graphincludes::params::verbose;
 258
 259   my $ok = 1;
 260   foreach my $node ($complete->get_edge_origins) {
 261     print STDERR '.' if $graphincludes::params::verbose;
 262     foreach my $child ($complete->get_dep_names_from($node)) {
 263       if (!$self->has_path($node, $child)) {
 264         print STDERR "ERROR: missing edge from $node to $child\n"
 265           if $graphincludes::params::debug;
 266         $ok = 0;
 267       }
 268     }
 269   }
 270   printf STDERR " %s.\n", ($ok ? "ok" : "FAILED")
 271     if $graphincludes::params::verbose;
 272
 273   return $ok;
 274 }
 275
 276 1;