bin/auto-graph.pl

   1 #!/usr/bin/perl
   2
   3 # $Id: auto-graph.pl,v 1.1 2003-04-03 19:30:48 kycl4rk Exp $
   4
   5 =head1 NAME
   6
   7 auto-graph.pl - Automatically create a graph from a database schema
   8
   9 =head1 SYNOPSIS
  10
  11   ./auto-graph.pl -d|--db=db_parser [options] schema.sql
  12
  13   Options:
  14
  15     -l|--layout        Layout schema for GraphViz
  16                        ("dot," "neato," "twopi"; default "dot")
  17     -n|--node-shape    Shape of the nodes ("record," "plaintext,"
  18                        "ellipse," "circle," "egg," "triangle," "box,"
  19                        "diamond," "trapezium," "parallelogram," "house,"
  20                        "hexagon," "octagon," default "ellipse")
  21     -o|--output        Output file name (default STDOUT)
  22     -t|--output-type   Output file type ("canon", "text," "ps," "hpgl,"
  23                        "pcl," "mif," "pic," "gd," "gd2," "gif," "jpeg,"
  24                        "png," "wbmp," "cmap," "ismap," "imap," "vrml,"
  25                        "vtx," "mp," "fig," "svg," "plain," default "png")
  26     --color            Add colors
  27     --natural-join     Perform natural joins
  28     --natural-join-pk  Perform natural joins from primary keys only
  29     -s|--skip          Fields to skip in natural joins
  30     --debug            Print debugging information
  31
  32 =head1 DESCRIPTION
  33
  34 This script will create a graph of your schema.  Only the database
  35 driver argument (for SQL::Translator) is required.  If no output file
  36 name is given, then image will be printed to STDOUT, so you should
  37 redirect the output into a file.
  38
  39 The default action is to assume the presence of foreign key
  40 relationships defined via "REFERNCES" or "FOREIGN KEY" constraints on
  41 the tables.  If you are parsing the schema of a file that does not
  42 have these, you will find the natural join options helpful.  With
  43 natural joins, like-named fields will be considered foreign keys.
  44 This can prove too permissive, however, as you probably don't want a
  45 field called "name" to be considered a foreign key, so you could
  46 include it in the "skip" option, and all fields called "name" will be
  47 excluded from natural joins.  A more efficient method, however, might
  48 be to simply deduce the foriegn keys from primary keys to other fields
  49 named the same in other tables.  Use the "natural-join-pk" option
  50 to acheive this.
  51
  52 If the schema defines foreign keys, then the graph produced will be
  53 directed showing the direction of the relationship.  If the foreign
  54 keys are intuited via natural joins, the graph will be undirected.
  55
  56 =cut
  57
  58 use strict;
  59 use Data::Dumper;
  60 use Getopt::Long;
  61 use GraphViz;
  62 use Pod::Usage;
  63 use SQL::Translator;
  64
  65 my $VERSION = (qw$Revision: 1.1 $)[-1];
  66
  67 use constant VALID_LAYOUT => {
  68     dot   => 1,
  69     neato => 1,
  70     twopi => 1,
  71 };
  72
  73 use constant VALID_NODE_SHAPE => {
  74     record        => 1,
  75     plaintext     => 1,
  76     ellipse       => 1,
  77     circle        => 1,
  78     egg           => 1,
  79     triangle      => 1,
  80     box           => 1,
  81     diamond       => 1,
  82     trapezium     => 1,
  83     parallelogram => 1,
  84     house         => 1,
  85     hexagon       => 1,
  86     octagon       => 1,
  87 };
  88
  89 use constant VALID_OUTPUT => {
  90     canon => 1,
  91     text  => 1,
  92     ps    => 1,
  93     hpgl  => 1,
  94     pcl   => 1,
  95     mif   => 1,
  96     pic   => 1,
  97     gd    => 1,
  98     gd2   => 1,
  99     gif   => 1,
 100     jpeg  => 1,
 101     png   => 1,
 102     wbmp  => 1,
 103     cmap  => 1,
 104     ismap => 1,
 105     imap  => 1,
 106     vrml  => 1,
 107     vtx   => 1,
 108     mp    => 1,
 109     fig   => 1,
 110     svg   => 1,
 111     plain => 1,
 112 };
 113
 114 #
 115 # Get arguments.
 116 #
 117 my (
 118     $layout, $node_shape, $out_file, $output_type, $db_driver, $add_color,
 119     $natural_join, $join_pk_only, $skip_fields, $debug
 120 );
 121
 122 GetOptions(
 123     'd|db=s'           => \$db_driver,
 124     'o|output:s'       => \$out_file,
 125     'l|layout:s'       => \$layout,
 126     'n|node-shape:s'   => \$node_shape,
 127     't|output-type:s'  => \$output_type,
 128     'color'            => \$add_color,
 129     'natural-join'     => \$natural_join,
 130     'natural-join-pk'  => \$join_pk_only,
 131     's|skip:s'         => \$skip_fields,
 132     'debug'            => \$debug,
 133 ) or die pod2usage;
 134 my $file = shift @ARGV or pod2usage( -message => 'No input file' );
 135
 136 pod2usage( -message => "No db driver specified" ) unless $db_driver;
 137
 138 my %skip        = map { $_, 1 } split ( /,/, $skip_fields );
 139 $natural_join ||= $join_pk_only;
 140 $layout         = 'dot'     unless VALID_LAYOUT->{ $layout };
 141 $node_shape     = 'ellipse' unless VALID_NODE_SHAPE->{ $node_shape };
 142 $output_type    = 'png'     unless VALID_OUTPUT->{ $output_type };
 143
 144 #
 145 # Create GraphViz and see if we can produce the output type.
 146 #
 147 my $gv            =  GraphViz->new(
 148     directed      => $natural_join ? 0 : 1,
 149     layout        => $layout,
 150     no_overlap    => 1,
 151     bgcolor       => $add_color ? 'lightgoldenrodyellow' : 'white',
 152     node          => {
 153         shape     => $node_shape,
 154         style     => 'filled',
 155         fillcolor => 'white'
 156     },
 157 ) or die "Can't create GraphViz object\n";
 158
 159 #die "GraphViz cannot produce files of type '$output_type'\n" unless
 160 #    $gv->can( "as_$output_type" );
 161
 162 #
 163 # Parse file.
 164 #
 165 warn "Parsing file '$file' with driver '$db_driver'\n" if $debug;
 166
 167 my $t    = SQL::Translator->new( parser => $db_driver, producer => 'Raw' );
 168 my $data = $t->translate( $file ) or die $t->error;
 169
 170 warn "Data =\n", Dumper( $data ), "\n" if $debug;
 171
 172 my %nj_registry; # for locations of fields for natural joins
 173 my @fk_registry; # for locations of fields for foreign keys
 174
 175 #
 176 # If necessary, pre-process fields to find foreign keys.
 177 #
 178 if ( $natural_join ) {
 179     my ( %common_keys, %pk );
 180     for my $table ( values %$data ) {
 181         for my $index (
 182             @{ $table->{'indices'}     || [] },
 183             @{ $table->{'constraints'} || [] },
 184         ) {
 185             my @fields = @{ $index->{'fields'} || [] } or next;
 186             if ( $index->{'type'} eq 'primary_key' ) {
 187                 $pk{ $_ } = 1 for @fields;
 188             }
 189         }
 190
 191         for my $field ( values %{ $table->{'fields'} } ) {
 192             push @{ $common_keys{ $field->{'name'} } }, $table->{'table_name'};
 193         }
 194     }
 195
 196     for my $field ( keys %common_keys ) {
 197         my @tables = @{ $common_keys{ $field } };
 198         next unless scalar @tables > 1;
 199         for my $table ( @tables ) {
 200             next if $join_pk_only and !defined $pk{ $field };
 201             $data->{ $table }{'fields'}{ $field }{'is_fk'} = 1;
 202         }
 203     }
 204 }
 205
 206 for my $table (
 207     map  { $_->[1] }
 208     sort { $a->[0] <=> $b->[0] }
 209     map  { [ $_->{'order'}, $_ ] }
 210     values %$data
 211 ) {
 212     my $table_name = $table->{'table_name'};
 213     $gv->add_node( $table_name );
 214
 215     warn "Processing table '$table_name'\n" if $debug;
 216
 217     my @fields =
 218         map  { $_->[1] }
 219         sort { $a->[0] <=> $b->[0] }
 220         map  { [ $_->{'order'}, $_ ] }
 221         values %{ $table->{'fields'} };
 222
 223     warn "Fields = ", join(', ', map { $_->{'name'} } @fields), "\n" if $debug;
 224
 225     my ( %pk, %unique );
 226     for my $index (
 227         @{ $table->{'indices'}     || [] },
 228         @{ $table->{'constraints'} || [] },
 229     ) {
 230         my @fields = @{ $index->{'fields'} || [] } or next;
 231         if ( $index->{'type'} eq 'primary_key' ) {
 232             $pk{ $_ } = 1 for @fields;
 233         }
 234         elsif ( $index->{'type'} eq 'unique' ) {
 235             $unique{ $_ } = 1 for @fields;
 236         }
 237     }
 238
 239     warn "Primary keys = ", join(', ', sort keys %pk), "\n" if $debug;
 240     warn "Unique = ", join(', ', sort keys %unique), "\n" if $debug;
 241
 242     for my $f ( @fields ) {
 243         my $name      = $f->{'name'} or next;
 244         my $is_pk     = $pk{ $name };
 245         my $is_unique = $unique{ $name };
 246
 247         #
 248         # Decide if we should skip this field.
 249         #
 250         if ( $natural_join ) {
 251             next unless $is_pk || $f->{'is_fk'};
 252         }
 253         else {
 254             next unless $is_pk ||
 255                 grep { $_->{'type'} eq 'foreign_key' }
 256                 @{ $f->{'constraints'} }
 257             ;
 258         }
 259
 260         my $constraints = $f->{'constraints'};
 261
 262         if ( $natural_join && !$skip{ $name } ) {
 263             push @{ $nj_registry{ $name } }, $table_name;
 264         }
 265         elsif ( @{ $constraints || [] } ) {
 266             for my $constraint ( @$constraints ) {
 267                 next unless $constraint->{'type'} eq 'foreign_key';
 268                 for my $fk_field (
 269                     @{ $constraint->{'reference_fields'} || [] }
 270                 ) {
 271                     my $fk_table = $constraint->{'reference_table'};
 272                     next unless defined $data->{ $fk_table };
 273                     push @fk_registry, [ $table_name, $fk_table ];
 274                 }
 275             }
 276         }
 277     }
 278 }
 279
 280 #
 281 # Make the connections.
 282 #
 283 my @table_bunches;
 284 if ( $natural_join ) {
 285     for my $field_name ( keys %nj_registry ) {
 286         my @table_names = @{ $nj_registry{ $field_name } || [] } or next;
 287         next if scalar @table_names == 1;
 288         push @table_bunches, [ @table_names ];
 289     }
 290 }
 291 else {
 292     @table_bunches = @fk_registry;
 293 }
 294
 295 my %done;
 296 for my $bunch ( @table_bunches ) {
 297     my @tables = @$bunch;
 298
 299     for my $i ( 0 .. $#tables ) {
 300         my $table1 = $tables[ $i ];
 301         for my $j ( 0 .. $#tables ) {
 302             my $table2 = $tables[ $j ];
 303             next if $table1 eq $table2;
 304             next if $done{ $table1 }{ $table2 };
 305             $gv->add_edge( $table1, $table2 );
 306             $done{ $table1 }{ $table2 } = 1;
 307             $done{ $table2 }{ $table1 } = 1;
 308         }
 309     }
 310 }
 311
 312 #
 313 # Print the image.
 314 #
 315 my $output_method = "as_$output_type";
 316 if ( $out_file ) {
 317     open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
 318     print $fh $gv->$output_method;
 319     close $fh;
 320     print "Image written to '$out_file'.  Done.\n";
 321 }
 322 else {
 323     print $gv->$output_method;
 324 }
 325
 326 =pod
 327
 328 =head1 AUTHOR
 329
 330 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 331
 332 =cut