Commit | Line | Data |
dd9550a4 |
1 | #!/usr/bin/perl |
2 | |
2621b0fc |
3 | # $Id: auto-dia.pl,v 1.8 2003-04-03 19:29:08 kycl4rk Exp $ |
dd9550a4 |
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 | |
2621b0fc |
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 |
dd9550a4 |
30 | |
31 | =head1 DESCRIPTION |
32 | |
33 | This script will create a picture of your schema. Only the database |
aa0a19b9 |
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. |
dd9550a4 |
37 | |
14655604 |
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 |
2621b0fc |
48 | named the same in other tables. Use the "natural-join-pk" option |
14655604 |
49 | to acheive this. |
50 | |
dd9550a4 |
51 | =cut |
52 | |
53 | use strict; |
2621b0fc |
54 | use Data::Dumper; |
dd9550a4 |
55 | use Getopt::Long; |
56 | use GD; |
57 | use Pod::Usage; |
58 | use SQL::Translator; |
59 | |
2621b0fc |
60 | my $VERSION = (qw$Revision: 1.8 $)[-1]; |
22cb6863 |
61 | |
62 | use constant VALID_FONT_SIZE => { |
63 | small => 1, |
64 | medium => 1, |
65 | large => 1, |
66 | huge => 1, |
67 | }; |
dd9550a4 |
68 | |
2621b0fc |
69 | use constant VALID_IMAGE_TYPE => { |
70 | png => 1, |
71 | jpeg => 1, |
72 | }; |
73 | |
aa0a19b9 |
74 | # |
75 | # Get arguments. |
76 | # |
14655604 |
77 | my ( |
78 | $out_file, $image_type, $db_driver, $title, $no_columns, |
2621b0fc |
79 | $no_lines, $font_size, $add_color, $debug, $show_fk_only, |
14655604 |
80 | $natural_join, $join_pk_only, $skip_fields |
81 | ); |
82 | |
dd9550a4 |
83 | GetOptions( |
2621b0fc |
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, |
dd9550a4 |
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; |
14655604 |
101 | $title ||= $file; |
2621b0fc |
102 | $image_type = 'png' unless VALID_IMAGE_TYPE ->{ $image_type }; |
14655604 |
103 | $font_size = 'medium' unless VALID_FONT_SIZE->{ $font_size }; |
104 | my %skip = map { $_, 1 } split ( /,/, $skip_fields ); |
105 | $natural_join ||= $join_pk_only; |
dd9550a4 |
106 | |
aa0a19b9 |
107 | # |
108 | # Parse file. |
109 | # |
2621b0fc |
110 | warn "Parsing file '$file' with driver '$db_driver'\n" if $debug; |
dd9550a4 |
111 | my $t = SQL::Translator->new( parser => $db_driver, producer => 'Raw' ); |
112 | my $data = $t->translate( $file ) or die $t->error; |
2621b0fc |
113 | warn "Data =\n", Dumper( $data ), "\n" if $debug; |
dd9550a4 |
114 | |
aa0a19b9 |
115 | # |
116 | # Layout the image. |
117 | # |
22cb6863 |
118 | my $font = |
119 | $font_size eq 'small' ? gdTinyFont : |
120 | $font_size eq 'medium' ? gdSmallFont : |
121 | $font_size eq 'large' ? gdLargeFont : gdGiantFont; |
dd9550a4 |
122 | my $no_tables = scalar keys %$data; |
123 | $no_columns ||= sprintf( "%.0f", sqrt( $no_tables ) + .5 ); |
2621b0fc |
124 | $no_columns ||= .5; |
dd9550a4 |
125 | my $no_per_col = sprintf( "%.0f", $no_tables/$no_columns + .5 ); |
dd9550a4 |
126 | |
7256996b |
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 |
2621b0fc |
130 | my ( $x, $y ) = (30, $orig_y); # where to start |
7256996b |
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 |
14655604 |
135 | my %nj_registry; # for locations of fields for natural joins |
136 | my @fk_registry; # for locations of fields for foreign keys |
7256996b |
137 | my %table_x; # for max x of each table |
138 | my $field_no; # counter to give distinct no. to each field |
b18a0413 |
139 | my %legend; |
dd9550a4 |
140 | |
2621b0fc |
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 | |
dd9550a4 |
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; |
aa0a19b9 |
195 | push @shapes, [ 'string', $font, $this_col_x, $y, $table_name, 'black' ]; |
dd9550a4 |
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 | |
2621b0fc |
202 | warn "Processing table '$table_name'\n" if $debug; |
203 | |
dd9550a4 |
204 | my @fields = |
205 | map { $_->[1] } |
206 | sort { $a->[0] <=> $b->[0] } |
207 | map { [ $_->{'order'}, $_ ] } |
208 | values %{ $table->{'fields'} }; |
209 | |
2621b0fc |
210 | warn "Fields = ", join(', ', map { $_->{'name'} } @fields), "\n" if $debug; |
211 | |
b18a0413 |
212 | my ( %pk, %unique ); |
2621b0fc |
213 | for my $index ( |
214 | @{ $table->{'indices'} || [] }, |
215 | @{ $table->{'constraints'} || [] }, |
216 | ) { |
dd9550a4 |
217 | my @fields = @{ $index->{'fields'} || [] } or next; |
b18a0413 |
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 | } |
dd9550a4 |
224 | } |
225 | |
2621b0fc |
226 | warn "Primary keys = ", join(', ', sort keys %pk), "\n" if $debug; |
227 | warn "Unique = ", join(', ', sort keys %unique), "\n" if $debug; |
228 | |
dd9550a4 |
229 | my ( @fld_desc, $max_name ); |
230 | for my $f ( @fields ) { |
b18a0413 |
231 | my $name = $f->{'name'} or next; |
232 | my $is_pk = $pk{ $name }; |
233 | my $is_unique = $unique{ $name }; |
2621b0fc |
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 | |
b18a0413 |
250 | if ( $is_pk ) { |
251 | $name .= ' *'; |
252 | $legend{'Primary key'} = '*'; |
253 | } |
254 | elsif ( $is_unique ) { |
255 | $name .= ' [U]'; |
256 | $legend{'Unique constraint'} = '[U]'; |
257 | } |
dd9550a4 |
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; |
7256996b |
266 | push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ]; |
dd9550a4 |
267 | } |
268 | |
269 | $max_name += 4; |
270 | for my $fld_desc ( @fld_desc ) { |
7256996b |
271 | my ( $name, $desc, $orig_name, $is_pk ) = @$fld_desc; |
dd9550a4 |
272 | my $diff = $max_name - length $name; |
273 | $name .= ' ' x $diff; |
274 | $desc = $name . $desc; |
275 | |
aa0a19b9 |
276 | push @shapes, [ 'string', $font, $this_col_x, $y, $desc, 'black' ]; |
dd9550a4 |
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; |
aa0a19b9 |
280 | |
14655604 |
281 | my $constraints = $table->{'fields'}{ $orig_name }{'constraints'}; |
282 | |
283 | if ( $natural_join && !$skip{ $orig_name } ) { |
284 | push @{ $nj_registry{ $orig_name } }, $table_name; |
aa0a19b9 |
285 | } |
14655604 |
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 | ) { |
2621b0fc |
292 | my $fk_table = $constraint->{'reference_table'}; |
293 | next unless defined $data->{ $fk_table }; |
14655604 |
294 | push @fk_registry, [ |
14655604 |
295 | [ $table_name, $orig_name ], |
2621b0fc |
296 | [ $fk_table , $fk_field ], |
14655604 |
297 | ]; |
298 | } |
299 | } |
300 | } |
301 | |
2621b0fc |
302 | my $y_link = $y - $font->height/2; |
14655604 |
303 | $table->{'fields'}{ $orig_name }{'coords'} = { |
2621b0fc |
304 | left => [ $this_col_x - 6, $y_link ], |
305 | right => [ $length + 2 , $y_link ], |
14655604 |
306 | table => $table_name, |
307 | field_no => ++$field_no, |
308 | is_pk => $is_pk, |
2621b0fc |
309 | fld_name => $orig_name, |
14655604 |
310 | }; |
dd9550a4 |
311 | } |
312 | |
313 | $this_max_x += 5; |
aa0a19b9 |
314 | $table_x{ $table_name } = $this_max_x + 5; |
dd9550a4 |
315 | push @shapes, [ 'line', $this_col_x - 5, $below_table_name, |
aa0a19b9 |
316 | $this_max_x, $below_table_name, 'black' ]; |
d21faa48 |
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' ]; |
dd9550a4 |
328 | $max_x = $this_max_x if $this_max_x > $max_x; |
329 | $y += 25; |
330 | |
7256996b |
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 |
dd9550a4 |
338 | } |
339 | } |
340 | |
341 | # |
aa0a19b9 |
342 | # Connect the lines. |
343 | # |
344 | my %horz_taken; |
345 | my %done; |
346 | unless ( $no_lines ) { |
14655604 |
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 ) { |
2621b0fc |
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 | ]; |
14655604 |
369 | } |
370 | } |
371 | |
2621b0fc |
372 | my $is_directed = $natural_join ? 0 : 1; |
373 | |
14655604 |
374 | for my $bunch ( @position_bunches ) { |
375 | my @positions = @$bunch; |
aa0a19b9 |
376 | |
377 | for my $i ( 0 .. $#positions ) { |
378 | my $pos1 = $positions[ $i ]; |
2621b0fc |
379 | my ( $ax, $ay ) = @{ $pos1->{'left'} || [] } or next; |
380 | my ( $bx, $by ) = @{ $pos1->{'right'} || [] } or next; |
aa0a19b9 |
381 | my $table1 = $pos1->{'table'}; |
382 | my $fno1 = $pos1->{'field_no'}; |
7256996b |
383 | my $is_pk = $pos1->{'is_pk'}; |
384 | next if $join_pk_only and !$is_pk; |
aa0a19b9 |
385 | |
7256996b |
386 | for my $j ( 0 .. $#positions ) { |
aa0a19b9 |
387 | my $pos2 = $positions[ $j ]; |
2621b0fc |
388 | my ( $cx, $cy ) = @{ $pos2->{'left'} || [] } or next; |
389 | my ( $dx, $dy ) = @{ $pos2->{'right'} || [] } or next; |
aa0a19b9 |
390 | my $table2 = $pos2->{'table'}; |
391 | my $fno2 = $pos2->{'field_no'}; |
2621b0fc |
392 | next if $table1 eq $table2; |
aa0a19b9 |
393 | next if $done{ $fno1 }{ $fno2 }; |
7256996b |
394 | next if $fno1 == $fno2; |
aa0a19b9 |
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 ); |
7256996b |
422 | my $offset = 9; |
aa0a19b9 |
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 | |
2621b0fc |
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 | |
aa0a19b9 |
483 | $done{ $fno1 }{ $fno2 } = 1; |
484 | $done{ $fno2 }{ $fno1 } = 1; |
485 | } |
486 | } |
487 | } |
488 | } |
489 | |
490 | # |
b18a0413 |
491 | # Add the title, legend and signature. |
dd9550a4 |
492 | # |
493 | my $large_font = gdLargeFont; |
494 | my $title_len = $large_font->width * length $title; |
aa0a19b9 |
495 | push @shapes, [ |
496 | 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black' |
497 | ]; |
dd9550a4 |
498 | |
b18a0413 |
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 | |
aa0a19b9 |
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 | ]; |
dd9550a4 |
529 | |
aa0a19b9 |
530 | # |
531 | # Render the image. |
532 | # |
2621b0fc |
533 | my $gd = GD::Image->new( $max_x + 30, $max_y ); |
dd9550a4 |
534 | unless ( $gd->can( $image_type ) ) { |
535 | die "GD can't create images of type '$image_type'\n"; |
536 | } |
aa0a19b9 |
537 | my %colors = map { $_->[0], $gd->colorAllocate( @{$_->[1]} ) } ( |
d21faa48 |
538 | [ white => [ 255, 255, 255 ] ], |
539 | [ beige => [ 245, 245, 220 ] ], |
540 | [ black => [ 0, 0, 0 ] ], |
541 | [ lightblue => [ 173, 216, 230 ] ], |
2621b0fc |
542 | [ cadetblue => [ 95, 158, 160 ] ], |
d21faa48 |
543 | [ lightgoldenrodyellow => [ 250, 250, 210 ] ], |
544 | [ khaki => [ 240, 230, 140 ] ], |
2621b0fc |
545 | [ red => [ 255, 0, 0 ] ], |
aa0a19b9 |
546 | ); |
dd9550a4 |
547 | $gd->interlaced( 'true' ); |
d21faa48 |
548 | my $background_color = $add_color ? 'lightgoldenrodyellow' : 'white'; |
549 | $gd->fill( 0, 0, $colors{ $background_color } ); |
dd9550a4 |
550 | for my $shape ( @shapes ) { |
551 | my $method = shift @$shape; |
aa0a19b9 |
552 | my $color = pop @$shape; |
553 | $gd->$method( @$shape, $colors{ $color } ); |
dd9550a4 |
554 | } |
555 | |
aa0a19b9 |
556 | # |
557 | # Print the image. |
558 | # |
dd9550a4 |
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 |