bin/auto-dia.pl

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