bin/auto-dia.pl

   1 #!/usr/bin/perl
   2
   3 # $Id: auto-dia.pl,v 1.3 2003-02-15 23:38:35 kycl4rk Exp $
   4
   5 =head1 NAME
   6
   7 auto-dia.pl - Automatically create a diagram from a database schema
   8
   9 =head1 SYNOPSIS
  10
  11   ./auto-dia.pl -d|--db=db_parser [options] schema.sql
  12
  13   Options:
  14
  15     -o|--output     Output file name (default STDOUT)
  16     -i|--image      Output image type (default PNG)
  17     -t|--title      Title to give schema
  18     -c|--cols       Number of columns
  19     -n|--no-lines   Don't draw lines
  20     -s|--skip       Fields to skip in natural joins
  21     --join-pk-only  Perform natural joins from primary keys only
  22
  23 =head1 DESCRIPTION
  24
  25 This script will create a picture of your schema.  Only the database
  26 driver argument (for SQL::Translator) is required.  If no output file
  27 name is given, then image will be printed to STDOUT, so you should
  28 redirect the output into a file.
  29
  30 =cut
  31
  32 use strict;
  33 use Getopt::Long;
  34 use GD;
  35 use Pod::Usage;
  36 use SQL::Translator;
  37
  38 my $VERSION = (qw$Revision: 1.3 $)[-1];
  39
  40 #
  41 # Get arguments.
  42 #
  43 my ( $out_file, $image_type, $db_driver, $title, $no_columns,
  44     $no_lines, $skip_fields, $join_pk_only );
  45 GetOptions(
  46     'd|db=s'         => \$db_driver,
  47     'o|output:s'     => \$out_file,
  48     'i|image:s'      => \$image_type,
  49     't|title:s'      => \$title,
  50     'c|columns:i'    => \$no_columns,
  51     'n|no-lines'     => \$no_lines,
  52     's|skip:s'       => \$skip_fields,
  53     '--join-pk-only' => \$join_pk_only,
  54 ) or die pod2usage;
  55 my $file = shift @ARGV or pod2usage( -message => 'No input file' );
  56
  57 pod2usage( -message => "No db driver specified" ) unless $db_driver;
  58 $image_type = $image_type ? lc $image_type : 'png';
  59 $title    ||= $file;
  60 my %skip    = map { $_, 1 } split ( /,/, $skip_fields );
  61
  62 #
  63 # Parse file.
  64 #
  65 my $t    = SQL::Translator->new( parser => $db_driver, producer => 'Raw' );
  66 my $data = $t->translate( $file ) or die $t->error;
  67 use Data::Dumper;
  68 #print Dumper( $data );
  69 #exit;
  70
  71 #
  72 # Layout the image.
  73 #
  74 my $font         = gdTinyFont;
  75 my $no_tables    = scalar keys %$data;
  76 $no_columns    ||= sprintf( "%.0f", sqrt( $no_tables ) + .5 );
  77 my $no_per_col   = sprintf( "%.0f", $no_tables/$no_columns + .5 );
  78
  79 my @shapes;
  80 my ( $max_x, $max_y );           # the furthest x and y used
  81 my $orig_y      = 40;            # used to reset y for each column
  82 my ( $x, $y )   = (20, $orig_y); # where to start
  83 my $cur_col     = 1;             # the current column
  84 my $no_this_col = 0;             # number of tables in current column
  85 my $this_col_x  = $x;            # current column's x
  86 my $gutter      = 30;            # distance b/w columns
  87 my %registry;                    # for locations of fields
  88 my %table_x;                     # for max x of each table
  89 my $field_no;                    # counter to give distinct no. to each field
  90
  91 for my $table (
  92     map  { $_->[1] }
  93     sort { $a->[0] <=> $b->[0] }
  94     map  { [ $_->{'order'}, $_ ] }
  95     values %$data
  96 ) {
  97     my $table_name = $table->{'table_name'};
  98     my $top        = $y;
  99     push @shapes, [ 'string', $font, $this_col_x, $y, $table_name, 'black' ];
 100
 101     $y                   += $font->height + 2;
 102     my $below_table_name  = $y;
 103     $y                   += 2;
 104     my $this_max_x        = $this_col_x + ($font->width * length($table_name));
 105
 106     my @fields =
 107         map  { $_->[1] }
 108         sort { $a->[0] <=> $b->[0] }
 109         map  { [ $_->{'order'}, $_ ] }
 110         values %{ $table->{'fields'} };
 111
 112     my %pk;
 113     for my $index ( @{ $table->{'indices'} || [] } ) {
 114         next unless $index->{'type'} eq 'primary_key';
 115         my @fields = @{ $index->{'fields'} || [] } or next;
 116         $pk{ $_ } = 1 for @fields;
 117     }
 118
 119     my ( @fld_desc, $max_name );
 120     for my $f ( @fields ) {
 121         my $name  = $f->{'name'} or next;
 122         my $is_pk = $pk{ $name };
 123         $name   .= ' *' if $is_pk;
 124
 125         my $size = @{ $f->{'size'} || [] }
 126             ? '(' . join( ',', @{ $f->{'size'} } ) . ')'
 127             : '';
 128         my $desc = join( ' ', map { $_ || () } $f->{'data_type'}, $size );
 129
 130         my $nlen  = length $name;
 131         $max_name = $nlen if $nlen > $max_name;
 132         push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ];
 133     }
 134
 135     $max_name += 4;
 136     for my $fld_desc ( @fld_desc ) {
 137         my ( $name, $desc, $orig_name, $is_pk ) = @$fld_desc;
 138         my $diff = $max_name - length $name;
 139         $name   .= ' ' x $diff;
 140         $desc    = $name . $desc;
 141
 142         push @shapes, [ 'string', $font, $this_col_x, $y, $desc, 'black' ];
 143         $y         += $font->height + 2;
 144         my $length  = $this_col_x + ( $font->width * length( $desc ) );
 145         $this_max_x = $length if $length > $this_max_x;
 146
 147         unless ( $skip{ $orig_name } ) {
 148             my $y_link = $y - $font->height * .75;
 149             push @{ $registry{ $orig_name } }, {
 150                 left     => [ $this_col_x - 2, $y_link ],
 151                 right    => [ $length,         $y_link ],
 152                 table    => $table_name,
 153                 field_no => ++$field_no,
 154                 is_pk    => $is_pk,
 155             };
 156         }
 157     }
 158
 159     $this_max_x += 5;
 160     $table_x{ $table_name } = $this_max_x + 5;
 161     push @shapes, [ 'line', $this_col_x - 5, $below_table_name,
 162         $this_max_x, $below_table_name, 'black' ];
 163     push @shapes, [
 164         'rectangle', $this_col_x - 5, $top - 5, $this_max_x, $y + 5, 'black'
 165     ];
 166     $max_x = $this_max_x if $this_max_x > $max_x;
 167     $y    += 25;
 168
 169     if ( ++$no_this_col == $no_per_col ) { # if we've filled up this column
 170         $cur_col++;                        # up the column number
 171         $no_this_col = 0;                  # reset the number of tables
 172         $max_x      += $gutter;            # push the x over for next column
 173         $this_col_x  = $max_x;             # remember the max x for this column
 174         $max_y       = $y if $y > $max_y;  # note the max y
 175         $y           = $orig_y;            # reset the y for next column
 176     }
 177 }
 178
 179 #
 180 # Connect the lines.
 181 #
 182 my %horz_taken;
 183 my %done;
 184 unless ( $no_lines ) {
 185     for my $field_name ( keys %registry ) {
 186         my @positions = @{ $registry{ $field_name } || [] } or next;
 187         next if scalar @positions == 1;
 188
 189         for my $i ( 0 .. $#positions ) {
 190             my $pos1        = $positions[ $i ];
 191             my ( $ax, $ay ) = @{ $pos1->{'left'}  };
 192             my ( $bx, $by ) = @{ $pos1->{'right'} };
 193             my $table1      = $pos1->{'table'};
 194             my $fno1        = $pos1->{'field_no'};
 195             my $is_pk       = $pos1->{'is_pk'};
 196             next if $join_pk_only and !$is_pk;
 197
 198             for my $j ( 0 .. $#positions ) {
 199                 my $pos2        = $positions[ $j ];
 200                 my ( $cx, $cy ) = @{ $pos2->{'left'}  };
 201                 my ( $dx, $dy ) = @{ $pos2->{'right'} };
 202                 my $table2      = $pos2->{'table'};
 203                 my $fno2        = $pos2->{'field_no'};
 204                 next if $done{ $fno1 }{ $fno2 };
 205                 next if $fno1 == $fno2;
 206
 207                 my @distances = ();
 208                 push @distances, [
 209                     abs ( $ax - $cx ) + abs ( $ay - $cy ),
 210                     [ $ax, $ay, $cx, $cy ],
 211                     [ 'left', 'left' ]
 212                 ];
 213                 push @distances, [
 214                     abs ( $ax - $dx ) + abs ( $ay - $dy ),
 215                     [ $ax, $ay, $dx, $dy ],
 216                     [ 'left', 'right' ],
 217                 ];
 218                 push @distances, [
 219                     abs ( $bx - $cx ) + abs ( $by - $cy ),
 220                     [ $bx, $by, $cx, $cy ],
 221                     [ 'right', 'left' ],
 222                 ];
 223                 push @distances, [
 224                     abs ( $bx - $dx ) + abs ( $by - $dy ),
 225                     [ $bx, $by, $dx, $dy ],
 226                     [ 'right', 'right' ],
 227                 ];
 228                 @distances   = sort { $a->[0] <=> $b->[0] } @distances;
 229                 my $shortest = $distances[0];
 230                 my ( $x1, $y1, $x2, $y2 ) = @{ $shortest->[1] };
 231                 my ( $side1, $side2     ) = @{ $shortest->[2] };
 232                 my ( $start, $end );
 233                 my $offset     = 9;
 234                 my $col1_right = $table_x{ $table1 };
 235                 my $col2_right = $table_x{ $table2 };
 236
 237                 my $diff = 0;
 238                 if ( $x1 == $x2 ) {
 239                     while ( $horz_taken{ $x1 + $diff } ) {
 240                         $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2;
 241                     }
 242                     $horz_taken{ $x1 + $diff } = 1;
 243                 }
 244
 245                 if ( $side1 eq 'left' ) {
 246                     $start = $x1 - $offset + $diff;
 247                 }
 248                 else {
 249                     $start = $col1_right + $diff;
 250                 }
 251
 252                 if ( $side2 eq 'left' ) {
 253                     $end = $x2 - $offset + $diff;
 254                 }
 255                 else {
 256                     $end = $col2_right + $diff;
 257                 }
 258
 259                 push @shapes, [ 'line', $x1,    $y1, $start, $y1, 'lightblue' ];
 260                 push @shapes, [ 'line', $start, $y1, $end,   $y2, 'lightblue' ];
 261                 push @shapes, [ 'line', $end,   $y2, $x2,    $y2, 'lightblue' ];
 262                 $done{ $fno1 }{ $fno2 } = 1;
 263                 $done{ $fno2 }{ $fno1 } = 1;
 264             }
 265         }
 266     }
 267 }
 268
 269 #
 270 # Add the title and signature.
 271 #
 272 my $large_font = gdLargeFont;
 273 my $title_len  = $large_font->width * length $title;
 274 push @shapes, [
 275     'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black'
 276 ];
 277
 278 my $sig     = "auto-dia.pl $VERSION";
 279 my $sig_len = $font->width * length $sig;
 280 push @shapes, [
 281     'string', $font, $max_x - $sig_len, $max_y - $font->height - 4,
 282     $sig, 'black'
 283 ];
 284
 285 #
 286 # Render the image.
 287 #
 288 my $gd = GD::Image->new( $max_x + 10, $max_y );
 289 unless ( $gd->can( $image_type ) ) {
 290     die "GD can't create images of type '$image_type'\n";
 291 }
 292 my %colors = map { $_->[0], $gd->colorAllocate( @{$_->[1]} ) } (
 293     [ white     => [ 255, 255, 255 ] ],
 294     [ black     => [   0,   0,   0 ] ],
 295     [ lightblue => [ 173, 216, 230 ] ],
 296 );
 297 $gd->interlaced( 'true' );
 298 $gd->fill( 0, 0, $colors{ 'white' } );
 299 for my $shape ( @shapes ) {
 300     my $method = shift @$shape;
 301     my $color  = pop   @$shape;
 302     $gd->$method( @$shape, $colors{ $color } );
 303 }
 304
 305 #
 306 # Print the image.
 307 #
 308 if ( $out_file ) {
 309     open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
 310     print $fh $gd->$image_type;
 311     close $fh;
 312     print "Image written to '$out_file'.  Done.\n";
 313 }
 314 else {
 315     print $gd->$image_type;
 316 }
 317
 318 =pod
 319
 320 =head1 AUTHOR
 321
 322 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 323
 324 =cut