lib/SQL/Translator/Producer/GraphViz.pm

   1 package SQL::Translator::Producer::GraphViz;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: GraphViz.pm,v 1.11 2004-02-11 21:31:03 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   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.11 $ =~ /(\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 $show_datatypes   = $args->{'show_datatypes'};
 100     my $show_sizes       = $args->{'show_sizes'};
 101     my $show_constraints = $args->{'show_constraints'};
 102     my $join_pk_only     = $args->{'join_pk_only'};
 103     my $skip_fields      = $args->{'skip_fields'};
 104     my %skip             = map { s/^\s+|\s+$//g; $_, 1 }
 105                            split ( /,/, $skip_fields );
 106     $natural_join      ||= $join_pk_only;
 107
 108     $schema->make_natural_joins(
 109         join_pk_only => $join_pk_only,
 110         skip_fields  => $args->{'skip_fields'},
 111     ) if $natural_join;
 112
 113     die "Invalid layout '$layout'" unless VALID_LAYOUT->{ $layout };
 114     die "Invalid output type: '$output_type'"
 115         unless VALID_OUTPUT->{ $output_type };
 116     die "Invalid node shape'$node_shape'"
 117         unless VALID_NODE_SHAPE->{ $node_shape };
 118
 119     for ( $height, $width ) {
 120         $_ = 0 unless $_ =~ /^\d+(.\d)?$/;
 121         $_ = 0 if $_ < 0;
 122     }
 123
 124     #
 125     # Create GraphViz and see if we can produce the output type.
 126     #
 127     my %args = (
 128         directed      => $natural_join ? 0 : 1,
 129         layout        => $layout,
 130         no_overlap    => 1,
 131         bgcolor       => $add_color ? 'lightgoldenrodyellow' : 'white',
 132         node          => {
 133             shape     => $node_shape,
 134             style     => 'filled',
 135             fillcolor => 'white'
 136         }
 137     );
 138     $args{'width'}  = $width  if $width;
 139     $args{'height'} = $height if $height;
 140
 141     my $gv =  GraphViz->new( %args ) or die "Can't create GraphViz object\n";
 142
 143     my %nj_registry; # for locations of fields for natural joins
 144     my @fk_registry; # for locations of fields for foreign keys
 145
 146     for my $table ( $schema->get_tables ) {
 147         my $table_name = $table->name;
 148         my @fields     = $table->get_fields;
 149         if ( $show_fk_only ) {
 150             @fields = grep { $_->is_foreign_key } @fields;
 151         }
 152
 153         my $field_str = join(
 154             '\l',
 155             map {
 156                 '-\ '
 157                 . $_->name
 158                 . ( $show_datatypes ? '\ ' . $_->data_type : '')
 159                 . ( $show_sizes && ! $show_datatypes ? '\ ' : '')
 160                 . ( $show_sizes && $_->data_type =~ /^(VAR)?CHAR2?$/i ? '(' . $_->size . ')' : '')
 161                 . ( $show_constraints ?
 162                     ( $_->is_primary_key || $_->is_foreign_key || $_->is_unique ? '\ [' : '' )
 163                     . ( $_->is_primary_key ? 'PK' : '' )
 164                     . ( $_->is_primary_key && ($_->is_foreign_key || $_->is_unique) ? ',' : '' )
 165                     . ( $_->is_foreign_key ? 'FK' : '' )
 166                     . ( $_->is_unique && ($_->is_primary_key || $_->is_foreign_key) ? ',' : '' )
 167                     . ( $_->is_unique ? 'U' : '' )
 168                     . ( $_->is_primary_key || $_->is_foreign_key || $_->is_unique ? ']' : '' )
 169                 : '' )
 170                 . '\ '
 171             } @fields
 172         ) . '\l';
 173         my $label = $show_fields ? "{$table_name|$field_str}" : $table_name;
 174         $gv->add_node( $table_name, label => $label );
 175
 176         debug("Processing table '$table_name'");
 177
 178         debug("Fields = ", join(', ', map { $_->name } @fields));
 179
 180         for my $f ( @fields ) {
 181             my $name      = $f->name or next;
 182             my $is_pk     = $f->is_primary_key;
 183             my $is_unique = $f->is_unique;
 184
 185             #
 186             # Decide if we should skip this field.
 187             #
 188             if ( $natural_join ) {
 189                 next unless $is_pk || $f->is_foreign_key;
 190             }
 191
 192             my $constraints = $f->{'constraints'};
 193
 194             if ( $natural_join && !$skip{ $name } ) {
 195                 push @{ $nj_registry{ $name } }, $table_name;
 196             }
 197         }
 198
 199         unless ( $natural_join ) {
 200             for my $c ( $table->get_constraints ) {
 201                 next unless $c->type eq FOREIGN_KEY;
 202                 my $fk_table = $c->reference_table or next;
 203
 204                 for my $field_name ( $c->fields ) {
 205                     for my $fk_field ( $c->reference_fields ) {
 206                         next unless defined $schema->get_table( $fk_table );
 207                         push @fk_registry, [ $table_name, $fk_table ];
 208                     }
 209                 }
 210             }
 211         }
 212     }
 213
 214     #
 215     # Make the connections.
 216     #
 217     my @table_bunches;
 218     if ( $natural_join ) {
 219         for my $field_name ( keys %nj_registry ) {
 220             my @table_names = @{ $nj_registry{ $field_name } || [] } or next;
 221             next if scalar @table_names == 1;
 222             push @table_bunches, [ @table_names ];
 223         }
 224     }
 225     else {
 226         @table_bunches = @fk_registry;
 227     }
 228
 229     my %done;
 230     for my $bunch ( @table_bunches ) {
 231         my @tables = @$bunch;
 232
 233         for my $i ( 0 .. $#tables ) {
 234             my $table1 = $tables[ $i ];
 235             for my $j ( 0 .. $#tables ) {
 236                 my $table2 = $tables[ $j ];
 237                 next if $table1 eq $table2;
 238                 next if $done{ $table1 }{ $table2 };
 239                 $gv->add_edge( $table2, $table1 );
 240                 $done{ $table1 }{ $table2 } = 1;
 241                 $done{ $table2 }{ $table1 } = 1;
 242             }
 243         }
 244     }
 245
 246     #
 247     # Print the image.
 248     #
 249     my $output_method = "as_$output_type";
 250     if ( $out_file ) {
 251         open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
 252         binmode $fh;
 253         print $fh $gv->$output_method;
 254         close $fh;
 255     }
 256     else {
 257         return $gv->$output_method;
 258     }
 259 }
 260
 261 1;
 262
 263 # -------------------------------------------------------------------
 264
 265 =pod
 266
 267 =head1 NAME
 268
 269 SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator
 270
 271 =head1 AUTHOR
 272
 273 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 274
 275 =cut