lib/SQL/Translator/Producer/GraphViz.pm

   1 package SQL::Translator::Producer::GraphViz;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: GraphViz.pm,v 1.8 2003-08-21 02:52:40 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 use strict;
  24 use GraphViz;
  25 use Data::Dumper;
  26 use SQL::Translator::Schema::Constants;
  27 use SQL::Translator::Utils qw(debug);
  28
  29 use vars qw[ $VERSION $DEBUG ];
  30 $VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/;
  31 $DEBUG   = 0 unless defined $DEBUG;
  32
  33 use constant VALID_LAYOUT => {
  34     dot   => 1,
  35     neato => 1,
  36     twopi => 1,
  37 };
  38
  39 use constant VALID_NODE_SHAPE => {
  40     record        => 1,
  41     plaintext     => 1,
  42     ellipse       => 1,
  43     circle        => 1,
  44     egg           => 1,
  45     triangle      => 1,
  46     box           => 1,
  47     diamond       => 1,
  48     trapezium     => 1,
  49     parallelogram => 1,
  50     house         => 1,
  51     hexagon       => 1,
  52     octagon       => 1,
  53 };
  54
  55 use constant VALID_OUTPUT => {
  56     canon => 1,
  57     text  => 1,
  58     ps    => 1,
  59     hpgl  => 1,
  60     pcl   => 1,
  61     mif   => 1,
  62     pic   => 1,
  63     gd    => 1,
  64     gd2   => 1,
  65     gif   => 1,
  66     jpeg  => 1,
  67     png   => 1,
  68     wbmp  => 1,
  69     cmap  => 1,
  70     ismap => 1,
  71     imap  => 1,
  72     vrml  => 1,
  73     vtx   => 1,
  74     mp    => 1,
  75     fig   => 1,
  76     svg   => 1,
  77     plain => 1,
  78 };
  79
  80 sub produce {
  81     my $t          = shift;
  82     my $schema     = $t->schema;
  83     my $args       = $t->producer_args;
  84     local $DEBUG   = $t->debug;
  85
  86     my $out_file        = $args->{'out_file'}    || '';
  87     my $layout          = $args->{'layout'}      || 'dot';
  88     my $node_shape      = $args->{'node_shape'}  || 'record';
  89     my $output_type     = $args->{'output_type'} || 'png';
  90     my $width           = defined $args->{'width'}
  91                           ? $args->{'width'} : 8.5;
  92     my $height          = defined $args->{'height'}
  93                           ? $args->{'height'} : 11;
  94     my $show_fields     = defined $args->{'show_fields'}
  95                           ? $args->{'show_fields'} : 1;
  96     my $add_color       = $args->{'add_color'};
  97     my $natural_join    = $args->{'natural_join'};
  98     my $show_fk_only    = $args->{'show_fk_only'};
  99     my $join_pk_only    = $args->{'join_pk_only'};
 100     my $skip_fields     = $args->{'skip_fields'};
 101     my %skip            = map { s/^\s+|\s+$//g; $_, 1 }
 102                           split ( /,/, $skip_fields );
 103     $natural_join     ||= $join_pk_only;
 104
 105     $schema->make_natural_joins(
 106         join_pk_only => $join_pk_only,
 107         skip_fields  => $args->{'skip_fields'},
 108     ) if $natural_join;
 109
 110     die "Invalid layout '$layout'" unless VALID_LAYOUT->{ $layout };
 111     die "Invalid output type: '$output_type'"
 112         unless VALID_OUTPUT->{ $output_type };
 113     die "Invalid node shape'$node_shape'"
 114         unless VALID_NODE_SHAPE->{ $node_shape };
 115
 116     for ( $height, $width ) {
 117         $_ = 0 unless $_ =~ /^\d+(.\d)?$/;
 118         $_ = 0 if $_ < 0;
 119     }
 120
 121     #
 122     # Create GraphViz and see if we can produce the output type.
 123     #
 124     my %args = (
 125         directed      => $natural_join ? 0 : 1,
 126         layout        => $layout,
 127         no_overlap    => 1,
 128         bgcolor       => $add_color ? 'lightgoldenrodyellow' : 'white',
 129         node          => {
 130             shape     => $node_shape,
 131             style     => 'filled',
 132             fillcolor => 'white'
 133         }
 134     );
 135     $args{'width'}  = $width  if $width;
 136     $args{'height'} = $height if $height;
 137
 138     my $gv =  GraphViz->new( %args ) or die "Can't create GraphViz object\n";
 139
 140     my %nj_registry; # for locations of fields for natural joins
 141     my @fk_registry; # for locations of fields for foreign keys
 142
 143     for my $table ( $schema->get_tables ) {
 144         my $table_name = $table->name;
 145         my @fields     = $table->get_fields;
 146         if ( $show_fk_only ) {
 147             @fields = grep { $_->is_foreign_key } @fields;
 148         }
 149
 150         my $field_str = join('\l', map { $_->name } @fields);
 151         my $label = $show_fields ? "{$table_name|$field_str}" : $table_name;
 152         $gv->add_node( $table_name, label => $label );
 153
 154         debug("Processing table '$table_name'");
 155
 156         debug("Fields = ", join(', ', map { $_->name } @fields));
 157
 158         for my $f ( @fields ) {
 159             my $name      = $f->name or next;
 160             my $is_pk     = $f->is_primary_key;
 161             my $is_unique = $f->is_unique;
 162
 163             #
 164             # Decide if we should skip this field.
 165             #
 166             if ( $natural_join ) {
 167                 next unless $is_pk || $f->is_foreign_key;
 168             }
 169
 170             my $constraints = $f->{'constraints'};
 171
 172             if ( $natural_join && !$skip{ $name } ) {
 173                 push @{ $nj_registry{ $name } }, $table_name;
 174             }
 175         }
 176
 177         unless ( $natural_join ) {
 178             for my $c ( $table->get_constraints ) {
 179                 next unless $c->type eq FOREIGN_KEY;
 180                 my $fk_table = $c->reference_table or next;
 181
 182                 for my $field_name ( $c->fields ) {
 183                     for my $fk_field ( $c->reference_fields ) {
 184                         next unless defined $schema->get_table( $fk_table );
 185                         push @fk_registry, [ $table_name, $fk_table ];
 186                     }
 187                 }
 188             }
 189         }
 190     }
 191
 192     #
 193     # Make the connections.
 194     #
 195     my @table_bunches;
 196     if ( $natural_join ) {
 197         for my $field_name ( keys %nj_registry ) {
 198             my @table_names = @{ $nj_registry{ $field_name } || [] } or next;
 199             next if scalar @table_names == 1;
 200             push @table_bunches, [ @table_names ];
 201         }
 202     }
 203     else {
 204         @table_bunches = @fk_registry;
 205     }
 206
 207     my %done;
 208     for my $bunch ( @table_bunches ) {
 209         my @tables = @$bunch;
 210
 211         for my $i ( 0 .. $#tables ) {
 212             my $table1 = $tables[ $i ];
 213             for my $j ( 0 .. $#tables ) {
 214                 my $table2 = $tables[ $j ];
 215                 next if $table1 eq $table2;
 216                 next if $done{ $table1 }{ $table2 };
 217                 $gv->add_edge( $table2, $table1 );
 218                 $done{ $table1 }{ $table2 } = 1;
 219                 $done{ $table2 }{ $table1 } = 1;
 220             }
 221         }
 222     }
 223
 224     #
 225     # Print the image.
 226     #
 227     my $output_method = "as_$output_type";
 228     if ( $out_file ) {
 229         open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
 230         binmode $fh;
 231         print $fh $gv->$output_method;
 232         close $fh;
 233     }
 234     else {
 235         return $gv->$output_method;
 236     }
 237 }
 238
 239 1;
 240
 241 =pod
 242
 243 =head1 NAME
 244
 245 SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator
 246
 247 =head1 AUTHOR
 248
 249 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 250
 251 =cut