3 # $Id: auto-dia.pl,v 1.3 2003-02-15 23:38:35 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 (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
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.
38 my $VERSION = (qw$Revision: 1.3 $)[-1];
43 my ( $out_file, $image_type, $db_driver, $title, $no_columns,
44 $no_lines, $skip_fields, $join_pk_only );
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,
55 my $file = shift @ARGV or pod2usage( -message => 'No input file' );
57 pod2usage( -message => "No db driver specified" ) unless $db_driver;
58 $image_type = $image_type ? lc $image_type : 'png';
60 my %skip = map { $_, 1 } split ( /,/, $skip_fields );
65 my $t = SQL::Translator->new( parser => $db_driver, producer => 'Raw' );
66 my $data = $t->translate( $file ) or die $t->error;
68 #print Dumper( $data );
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 );
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
93 sort { $a->[0] <=> $b->[0] }
94 map { [ $_->{'order'}, $_ ] }
97 my $table_name = $table->{'table_name'};
99 push @shapes, [ 'string', $font, $this_col_x, $y, $table_name, 'black' ];
101 $y += $font->height + 2;
102 my $below_table_name = $y;
104 my $this_max_x = $this_col_x + ($font->width * length($table_name));
108 sort { $a->[0] <=> $b->[0] }
109 map { [ $_->{'order'}, $_ ] }
110 values %{ $table->{'fields'} };
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;
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;
125 my $size = @{ $f->{'size'} || [] }
126 ? '(' . join( ',', @{ $f->{'size'} } ) . ')'
128 my $desc = join( ' ', map { $_ || () } $f->{'data_type'}, $size );
130 my $nlen = length $name;
131 $max_name = $nlen if $nlen > $max_name;
132 push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ];
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;
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;
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,
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' ];
164 'rectangle', $this_col_x - 5, $top - 5, $this_max_x, $y + 5, 'black'
166 $max_x = $this_max_x if $this_max_x > $max_x;
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
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;
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;
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;
209 abs ( $ax - $cx ) + abs ( $ay - $cy ),
210 [ $ax, $ay, $cx, $cy ],
214 abs ( $ax - $dx ) + abs ( $ay - $dy ),
215 [ $ax, $ay, $dx, $dy ],
219 abs ( $bx - $cx ) + abs ( $by - $cy ),
220 [ $bx, $by, $cx, $cy ],
224 abs ( $bx - $dx ) + abs ( $by - $dy ),
225 [ $bx, $by, $dx, $dy ],
226 [ 'right', 'right' ],
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] };
234 my $col1_right = $table_x{ $table1 };
235 my $col2_right = $table_x{ $table2 };
239 while ( $horz_taken{ $x1 + $diff } ) {
240 $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2;
242 $horz_taken{ $x1 + $diff } = 1;
245 if ( $side1 eq 'left' ) {
246 $start = $x1 - $offset + $diff;
249 $start = $col1_right + $diff;
252 if ( $side2 eq 'left' ) {
253 $end = $x2 - $offset + $diff;
256 $end = $col2_right + $diff;
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;
270 # Add the title and signature.
272 my $large_font = gdLargeFont;
273 my $title_len = $large_font->width * length $title;
275 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black'
278 my $sig = "auto-dia.pl $VERSION";
279 my $sig_len = $font->width * length $sig;
281 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4,
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";
292 my %colors = map { $_->[0], $gd->colorAllocate( @{$_->[1]} ) } (
293 [ white => [ 255, 255, 255 ] ],
294 [ black => [ 0, 0, 0 ] ],
295 [ lightblue => [ 173, 216, 230 ] ],
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 } );
309 open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
310 print $fh $gd->$image_type;
312 print "Image written to '$out_file'. Done.\n";
315 print $gd->$image_type;
322 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>