3 # $Id: auto-dia.pl,v 1.8 2003-04-03 19:29:08 kycl4rk Exp $
7 auto-dia.pl - Automatically create a diagram from a database schema
11 ./auto-dia.pl -d|--db=db_parser [options] schema.sql
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,"
23 --show-fk-only Only show fields that act as primary
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
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.
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
60 my $VERSION = (qw$Revision: 1.8 $)[-1];
62 use constant VALID_FONT_SIZE => {
69 use constant VALID_IMAGE_TYPE => {
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
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,
98 my $file = shift @ARGV or pod2usage( -message => 'No input file' );
100 pod2usage( -message => "No db driver specified" ) unless $db_driver;
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;
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;
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 );
125 my $no_per_col = sprintf( "%.0f", $no_tables/$no_columns + .5 );
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
142 # If necessary, pre-process fields to find foreign keys.
144 if ( $show_fk_only && $natural_join ) {
145 my ( %common_keys, %pk );
146 for my $table ( values %$data ) {
148 @{ $table->{'indices'} || [] },
149 @{ $table->{'constraints'} || [] },
151 my @fields = @{ $index->{'fields'} || [] } or next;
152 if ( $index->{'type'} eq 'primary_key' ) {
153 $pk{ $_ } = 1 for @fields;
157 for my $field ( values %{ $table->{'fields'} } ) {
158 push @{ $common_keys{ $field->{'name'} } }, $table->{'table_name'};
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;
172 for my $table ( values %$data ) {
173 for my $field ( values %{ $table->{'fields'} } ) {
175 grep { $_->{'type'} eq 'foreign_key' }
176 @{ $field->{'constraints'} }
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;
189 sort { $a->[0] <=> $b->[0] }
190 map { [ $_->{'order'}, $_ ] }
193 my $table_name = $table->{'table_name'};
195 push @shapes, [ 'string', $font, $this_col_x, $y, $table_name, 'black' ];
197 $y += $font->height + 2;
198 my $below_table_name = $y;
200 my $this_max_x = $this_col_x + ($font->width * length($table_name));
202 warn "Processing table '$table_name'\n" if $debug;
206 sort { $a->[0] <=> $b->[0] }
207 map { [ $_->{'order'}, $_ ] }
208 values %{ $table->{'fields'} };
210 warn "Fields = ", join(', ', map { $_->{'name'} } @fields), "\n" if $debug;
214 @{ $table->{'indices'} || [] },
215 @{ $table->{'constraints'} || [] },
217 my @fields = @{ $index->{'fields'} || [] } or next;
218 if ( $index->{'type'} eq 'primary_key' ) {
219 $pk{ $_ } = 1 for @fields;
221 elsif ( $index->{'type'} eq 'unique' ) {
222 $unique{ $_ } = 1 for @fields;
226 warn "Primary keys = ", join(', ', sort keys %pk), "\n" if $debug;
227 warn "Unique = ", join(', ', sort keys %unique), "\n" if $debug;
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 };
236 # Decide if we should skip this field.
238 if ( $show_fk_only ) {
239 if ( $natural_join ) {
240 next unless $is_pk || $f->{'is_fk'};
243 next unless $is_pk || $f->{'is_fk'} ||
244 grep { $_->{'type'} eq 'foreign_key' }
245 @{ $f->{'constraints'} }
252 $legend{'Primary key'} = '*';
254 elsif ( $is_unique ) {
256 $legend{'Unique constraint'} = '[U]';
259 my $size = @{ $f->{'size'} || [] }
260 ? '(' . join( ',', @{ $f->{'size'} } ) . ')'
262 my $desc = join( ' ', map { $_ || () } $f->{'data_type'}, $size );
264 my $nlen = length $name;
265 $max_name = $nlen if $nlen > $max_name;
266 push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ];
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;
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;
281 my $constraints = $table->{'fields'}{ $orig_name }{'constraints'};
283 if ( $natural_join && !$skip{ $orig_name } ) {
284 push @{ $nj_registry{ $orig_name } }, $table_name;
286 elsif ( @{ $constraints || [] } ) {
287 for my $constraint ( @$constraints ) {
288 next unless $constraint->{'type'} eq 'foreign_key';
290 @{ $constraint->{'reference_fields'} || [] }
292 my $fk_table = $constraint->{'reference_table'};
293 next unless defined $data->{ $fk_table };
295 [ $table_name, $orig_name ],
296 [ $fk_table , $fk_field ],
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,
309 fld_name => $orig_name,
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 );
321 $bounds[0], $bounds[1],
322 $this_max_x, $below_table_name,
325 unshift @shapes, [ 'filledRectangle', @bounds, 'white' ];
327 push @shapes, [ 'rectangle', @bounds, 'black' ];
328 $max_x = $this_max_x if $this_max_x > $max_x;
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
346 unless ( $no_lines ) {
347 my @position_bunches;
349 if ( $natural_join ) {
350 for my $field_name ( keys %nj_registry ) {
352 my @table_names = @{ $nj_registry{ $field_name } || [] } or next;
353 next if scalar @table_names == 1;
355 for my $table_name ( @table_names ) {
357 $data->{ $table_name }{'fields'}{ $field_name }{'coords'};
360 push @position_bunches, [ @positions ];
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'},
372 my $is_directed = $natural_join ? 0 : 1;
374 for my $bunch ( @position_bunches ) {
375 my @positions = @$bunch;
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;
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;
398 abs ( $ax - $cx ) + abs ( $ay - $cy ),
399 [ $ax, $ay, $cx, $cy ],
403 abs ( $ax - $dx ) + abs ( $ay - $dy ),
404 [ $ax, $ay, $dx, $dy ],
408 abs ( $bx - $cx ) + abs ( $by - $cy ),
409 [ $bx, $by, $cx, $cy ],
413 abs ( $bx - $dx ) + abs ( $by - $dy ),
414 [ $bx, $by, $dx, $dy ],
415 [ 'right', 'right' ],
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] };
423 my $col1_right = $table_x{ $table1 };
424 my $col2_right = $table_x{ $table2 };
428 while ( $horz_taken{ $x1 + $diff } ) {
429 $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2;
431 $horz_taken{ $x1 + $diff } = 1;
434 if ( $side1 eq 'left' ) {
435 $start = $x1 - $offset + $diff;
438 $start = $col1_right + $diff;
441 if ( $side2 eq 'left' ) {
442 $end = $x2 - $offset + $diff;
445 $end = $col2_right + $diff;
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' ];
452 if ( $is_directed ) {
454 $side1 eq 'right' && $side2 eq 'left'
456 $side1 eq 'left' && $side2 eq 'left'
459 'line', $x2 - 3, $y2 - 3, $x2, $y2, 'cadetblue'
462 'line', $x2 - 3, $y2 + 3, $x2, $y2, 'cadetblue'
465 'line', $x2 - 3, $y2 - 3, $x2 - 3, $y2 +3,
471 'line', $x2 + 3, $y2 - 3, $x2, $y2, 'cadetblue'
474 'line', $x2 + 3, $y2 + 3, $x2, $y2, 'cadetblue'
477 'line', $x2 + 3, $y2 - 3, $x2 + 3, $y2 +3,
483 $done{ $fno1 }{ $fno2 } = 1;
484 $done{ $fno2 }{ $fno1 } = 1;
491 # Add the title, legend and signature.
493 my $large_font = gdLargeFont;
494 my $title_len = $large_font->width * length $title;
496 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black'
502 'string', $font, $x, $max_y - $font->height - 4, 'Legend', 'black'
504 $max_y += $font->height + 4;
507 for my $len ( map { length $_ } values %legend ) {
508 $longest = $len if $len > $longest;
512 while ( my ( $key, $shape ) = each %legend ) {
513 my $space = $longest - length $shape;
515 'string', $font, $x, $max_y - $font->height - 4,
516 join( '', $shape, ' ' x $space, $key ), 'black'
519 $max_y += $font->height + 4;
523 my $sig = "auto-dia.pl $VERSION";
524 my $sig_len = $font->width * length $sig;
526 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4,
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";
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 ] ],
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 } );
560 open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
561 print $fh $gd->$image_type;
563 print "Image written to '$out_file'. Done.\n";
566 print $gd->$image_type;
573 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>