lib/graphincludes/renderer/dot.pm

   1 # This file is part of the graph-includes package
   2 #
   3 # (c) 2005 Yann Dirson <ydirson@altern.org>
   4 # Distributed under version 2 of the GNU GPL.
   5
   6 package graphincludes::renderer::dot;
   7
   8 use warnings;
   9 use strict;
  10
  11 use base qw(graphincludes::renderer);
  12 use Hash::Util qw(lock_keys);
  13
  14 use graphincludes::params;
  15
  16 sub new {
  17   my $class = shift;
  18   my $self = {
  19               DOTFLAGS  => [],
  20               OUTFORMAT => undef,
  21              };
  22
  23   bless ($self, $class);
  24   lock_keys (%$self);
  25   return $self;
  26 }
  27
  28 my %paper = (
  29              a4     => '11.6,8.2',
  30              a3     => '16.5,11.6',
  31              letter => '11,8.5',
  32             );
  33
  34 #FIXME: also set arrow head
  35 my @paperparams = ('-Gnodesep=0.1', '-Granksep=0.1', '-Nfontsize=5', '-Efontsize=5');
  36
  37 sub set_multipage {
  38   my $self = shift;
  39   my ($papersize) = @_;
  40
  41   die "Unkown paper size \`$papersize'" unless defined $paper{$papersize};
  42   # paper output format is postscript on stdout unless otherwise specified
  43   $self->set_outputformat ('ps');
  44
  45   push @{$self->{DOTFLAGS}}, @paperparams, '-Gpage=' . $paper{$papersize};
  46 }
  47
  48 sub set_outputformat {
  49   my $self = shift;
  50   $self->{OUTFORMAT} = shift;
  51 }
  52
  53 sub set_outputfile {
  54   my $self = shift;
  55   my ($outfile) = @_;
  56
  57   push @{$self->{DOTFLAGS}}, '-o', $outfile;
  58
  59   $outfile =~ m/.*\.([^.]+)$/ or die "cannot guess output format";
  60   $self->set_outputformat ($1);
  61 }
  62
  63 sub printgraph {
  64   my $self = shift;
  65   my ($project, $colors, $colorstyles) = @_;
  66
  67   push @{$self->{DOTFLAGS}}, "-T$self->{OUTFORMAT}" if defined $self->{OUTFORMAT};
  68
  69   if (scalar(@{$self->{DOTFLAGS}}) > 0) {
  70     my $flags = join ' ', @{$self->{DOTFLAGS}};
  71     print STDERR "Running through \`dot $flags'\n" if $graphincludes::params::verbose;
  72     open STDOUT, "| dot $flags";
  73   }
  74
  75   print "strict digraph dependencies {\nrankdir=LR;\n";
  76
  77   sub sprintnode {
  78     my ($file, $min, $max) = @_;
  79     my $node = $project->filelabel($file,$max);
  80     if ($max > $min) {
  81       if (defined $node) {
  82         # this node is part of a larger group
  83         return "subgraph \"cluster $node\" {" . sprintnode($file, $min, $max-1) . '}';
  84       } else {
  85         return sprintnode($file, $min, $max-1);
  86       }
  87     } else { # ($min == $max)
  88       my $style='';
  89       my $idx;
  90
  91       # maybe use a background
  92       if (defined ($idx = $colorstyles->{bg}) and defined $colors->[$idx] and
  93           defined $project->filelabel($file,$idx) and
  94           defined $colors->[$idx]->{$project->filelabel($file,$idx)}) {
  95         $style .= ",style=filled,fillcolor=" . $colors->[$idx]->{$project->filelabel($file,$idx)};
  96       }
  97
  98       # maybe use an outline
  99       if (defined ($idx = $colorstyles->{border}) and defined $colors->[$idx] and
 100           defined $project->filelabel($file,$idx) and
 101           defined $colors->[$idx]->{$project->filelabel($file,$idx)}) {
 102         $style .= ",color=" . $colors->[$idx]->{$project->filelabel($file,$idx)};
 103       }
 104
 105       return "\"$node\" [label=\"$node\"" . $style . "];";
 106     }
 107   }
 108
 109   foreach my $file (@{$project->{FILES}}) {
 110     print sprintnode($file, $graphincludes::params::minshow, $graphincludes::params::maxshow), "\n";
 111   }
 112
 113   foreach my $file ($project->get_dep_origins) {
 114     foreach my $dest ($project->get_dependencies($file)) {
 115       print "\"$file\" -> \"$dest\"";
 116       my $special = $project->special_edge($file, $dest);
 117       # special handling for label, as array
 118       push @{$special->{label}}, '[' . $project->get_dependency_weight($file, $dest) . ']';
 119       $special->{label} = join '\n', @{$special->{label}};
 120       #
 121       print " [", join (',', map {$_ . '="' . $special->{$_} . '"'} keys %$special), "]" if defined $special;
 122       print ";\n";
 123     }
 124   }
 125
 126   print "}\n";
 127 }
 128
 129 sub wait {
 130   my $self = shift;
 131
 132   if (scalar(@{$self->{DOTFLAGS}}) > 0) {
 133     close STDOUT;
 134     wait;
 135   }
 136 }
 137
 138 1;