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