bin/auto-dia.pl

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