bin/auto-dia.pl

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