Commit | Line | Data |
37503827 |
1 | package SQL::Translator::Producer::Diagram; |
2 | |
e966b2b0 |
3 | =head1 NAME |
4 | |
5 | SQL::Translator::Producer::Diagram - ER diagram producer for SQL::Translator |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | Use via SQL::Translator: |
10 | |
11 | use SQL::Translator; |
12 | |
ea93df61 |
13 | my $t = SQL::Translator->new( |
14 | from => 'MySQL', |
00bc9c37 |
15 | to => 'Diagram', |
9d4a26be |
16 | producer_args => { |
17 | # All args are optional |
2627fb5e |
18 | out_file => 'schema.png',# if not provided will return from translate() |
9d4a26be |
19 | output_type => 'png', # is default or 'jpeg' |
20 | title => 'My Schema', # default is filename |
21 | font_size => 'medium', # is default or 'small,' 'large' |
22 | imap_file => '', # filename to write image map coords |
23 | imap_url => '', # base URL for image map |
24 | gutter => 30 # is default, px distance b/w cols |
25 | num_columns => 5, # the number of columns |
26 | no_lines => 1, # do not draw lines to show FKs |
27 | add_color => 1, # give it some color |
28 | show_fk_only => 1, # show only fields used in FKs |
29 | join_pk_only => 1, # use only primary keys to figure PKs |
30 | natural_join => 1, # intuit FKs if not defined |
31 | skip_fields => [...], # list* of field names to exclude |
32 | skip_tables => [...], # list* of table names to exclude |
33 | skip_tables_like => [...], # list* of regexen to exclude tables |
34 | } |
35 | ) or die SQL::Translator->error; |
e966b2b0 |
36 | $t->translate; |
37 | |
9d4a26be |
38 | * "list" can be either an array-ref or a comma-separated string |
39 | |
e966b2b0 |
40 | =cut |
41 | |
37503827 |
42 | use strict; |
f27f9229 |
43 | use warnings; |
37503827 |
44 | use GD; |
45 | use Data::Dumper; |
761fa621 |
46 | use SQL::Translator::Schema::Constants; |
37503827 |
47 | use SQL::Translator::Utils qw(debug); |
48 | |
0c04c5a2 |
49 | our $DEBUG; |
da93ce68 |
50 | our $VERSION = '1.60'; |
37503827 |
51 | $DEBUG = 0 unless defined $DEBUG; |
52 | |
53 | use constant VALID_FONT_SIZE => { |
54 | small => 1, |
55 | medium => 1, |
56 | large => 1, |
57 | huge => 1, |
58 | }; |
59 | |
60 | use constant VALID_IMAGE_TYPE => { |
61 | png => 1, |
62 | jpeg => 1, |
63 | }; |
64 | |
65 | sub produce { |
761fa621 |
66 | my $t = shift; |
67 | my $schema = $t->schema; |
37503827 |
68 | my $args = $t->producer_args; |
69 | local $DEBUG = $t->debug; |
fce0f0b5 |
70 | debug("Schema =\n", Dumper( $schema )) if $DEBUG; |
71 | debug("Producer args =\n", Dumper( $args )) if $DEBUG; |
37503827 |
72 | |
6a20798b |
73 | my $out_file = $args->{'out_file'} || ''; |
9d4a26be |
74 | my $output_type = $args->{'output_type'} || 'png'; |
6a20798b |
75 | my $title = $args->{'title'} || $t->filename; |
76 | my $font_size = $args->{'font_size'} || 'medium'; |
77 | my $imap_file = $args->{'imap_file'} || ''; |
78 | my $imap_url = $args->{'imap_url'} || ''; |
01a182ab |
79 | my $gutter = $args->{'gutter'} || 30; # distance b/w columns |
9d4a26be |
80 | my $num_columns = $args->{'num_columns'} || $args->{'no_columns'} || ''; |
37503827 |
81 | my $no_lines = $args->{'no_lines'}; |
82 | my $add_color = $args->{'add_color'}; |
83 | my $show_fk_only = $args->{'show_fk_only'}; |
84 | my $join_pk_only = $args->{'join_pk_only'}; |
85 | my $natural_join = $args->{'natural_join'} || $join_pk_only; |
9d4a26be |
86 | my %skip_field = map { $_, 1 } ( |
87 | ref $args->{'skip_fields'} eq 'ARRAY' |
88 | ? @{ $args->{'skip_fields'} } |
f27f9229 |
89 | : split ( /\s*,\s*/, $args->{'skip_fields'}||'' ) |
9d4a26be |
90 | ); |
91 | |
92 | my %skip_table = map { $_, 1 } ( |
93 | ref $args->{'skip_tables'} eq 'ARRAY' |
94 | ? @{ $args->{'skip_tables'} } |
f27f9229 |
95 | : split ( /\s*,\s*/, $args->{'skip_tables'}||'' ) |
9d4a26be |
96 | ); |
97 | |
98 | my @skip_tables_like = map { qr/$_/ } ( |
99 | ref $args->{'skip_tables_like'} eq 'ARRAY' |
100 | ? @{ $args->{'skip_tables_like'} } |
f27f9229 |
101 | : split ( /\s*,\s*/, $args->{'skip_tables_like'}||'' ) |
9d4a26be |
102 | ); |
761fa621 |
103 | |
dcac44eb |
104 | my @table_names; |
105 | if ( $natural_join ) { |
106 | $schema->make_natural_joins( |
107 | join_pk_only => $join_pk_only, |
108 | skip_fields => $args->{'skip_fields'}, |
109 | ); |
110 | |
ea93df61 |
111 | my $g = $schema->as_graph_pm; |
dcac44eb |
112 | my $d = Graph::Traversal::DFS->new( $g, next_alphabetic => 1 ); |
113 | $d->preorder; |
114 | |
ea93df61 |
115 | @table_names = $d->dfs; |
dcac44eb |
116 | } |
117 | else { |
118 | @table_names = map { $_->name } $schema->get_tables; |
119 | } |
37503827 |
120 | |
7652721a |
121 | die "Invalid image type '$output_type'" |
9d4a26be |
122 | unless VALID_IMAGE_TYPE->{ $output_type }; |
37503827 |
123 | die "Invalid font size '$font_size'" |
124 | unless VALID_FONT_SIZE->{ $font_size }; |
125 | |
126 | # |
127 | # Layout the image. |
128 | # |
dcac44eb |
129 | my $font |
ea93df61 |
130 | = $font_size eq 'small' ? gdTinyFont |
131 | : $font_size eq 'medium' ? gdSmallFont |
132 | : $font_size eq 'large' ? gdLargeFont |
dcac44eb |
133 | : gdGiantFont; |
134 | |
9d4a26be |
135 | my $num_tables = scalar @table_names; |
136 | $num_columns = 0 unless $num_columns =~ /^\d+$/; |
137 | $num_columns ||= sprintf( "%.0f", sqrt( $num_tables ) + .5 ); |
138 | $num_columns ||= .5; |
139 | my $no_per_col = sprintf( "%.0f", $num_tables/$num_columns + .5 ); |
37503827 |
140 | |
ea93df61 |
141 | my @shapes; |
37503827 |
142 | my ( $max_x, $max_y ); # the furthest x and y used |
143 | my $orig_y = 40; # used to reset y for each column |
144 | my ( $x, $y ) = (30,$orig_y); # where to start |
145 | my $cur_col = 1; # the current column |
146 | my $no_this_col = 0; # number of tables in current column |
147 | my $this_col_x = $x; # current column's x |
37503827 |
148 | my %nj_registry; # for locations of fields for natural joins |
149 | my @fk_registry; # for locations of fields for foreign keys |
150 | my %table_x; # for max x of each table |
151 | my $field_no; # counter to give distinct no. to each field |
761fa621 |
152 | my %coords; # holds fields coordinates |
6a20798b |
153 | my @imap_coords; # for making clickable image map |
37503827 |
154 | my %legend; |
155 | |
9d4a26be |
156 | TABLE: |
dcac44eb |
157 | for my $table_name ( @table_names ) { |
158 | my $table = $schema->get_table( $table_name ); |
9d4a26be |
159 | |
160 | if ( @skip_tables_like or keys %skip_table ) { |
161 | next TABLE if $skip_table{ $table_name }; |
162 | for my $regex ( @skip_tables_like ) { |
163 | next TABLE if $table_name =~ $regex; |
164 | } |
165 | } |
166 | |
dcac44eb |
167 | my $top = $y; |
ea93df61 |
168 | push @shapes, |
37503827 |
169 | [ 'string', $font, $this_col_x, $y, $table_name, 'black' ]; |
37503827 |
170 | $y += $font->height + 2; |
171 | my $below_table_name = $y; |
172 | $y += 2; |
ea93df61 |
173 | my $this_max_x = |
37503827 |
174 | $this_col_x + ($font->width * length($table_name)); |
175 | |
176 | debug("Processing table '$table_name'"); |
177 | |
761fa621 |
178 | my @fields = $table->get_fields; |
fce0f0b5 |
179 | debug("Fields = ", join(', ', map { $_->name } @fields)) if $DEBUG; |
37503827 |
180 | |
60dcc980 |
181 | my ( @fld_desc, $max_name, $max_desc ); |
37503827 |
182 | for my $f ( @fields ) { |
761fa621 |
183 | my $name = $f->name or next; |
184 | my $is_pk = $f->is_primary_key; |
37503827 |
185 | |
60dcc980 |
186 | my @attr; |
187 | |
37503827 |
188 | # |
189 | # Decide if we should skip this field. |
190 | # |
191 | if ( $show_fk_only ) { |
761fa621 |
192 | next unless $is_pk || $f->is_foreign_key; |
37503827 |
193 | } |
194 | |
195 | if ( $is_pk ) { |
60dcc980 |
196 | push @attr, 'PK'; |
197 | $legend{'Primary key'} = '[PK]'; |
37503827 |
198 | } |
cd9ccb3e |
199 | |
200 | if ( $f->is_unique ) { |
60dcc980 |
201 | push @attr, 'U'; |
37503827 |
202 | $legend{'Unique constraint'} = '[U]'; |
203 | } |
204 | |
60dcc980 |
205 | if ( $f->is_foreign_key ) { |
206 | push @attr, 'FK'; |
207 | $legend{'Foreign Key'} = '[FK]'; |
208 | } |
209 | |
210 | my $attr = ''; |
211 | if ( @attr ) { |
212 | $attr .= '[' . join(', ', @attr) . ']'; |
213 | } |
214 | |
761fa621 |
215 | my $desc = $f->data_type; |
60dcc980 |
216 | $desc .= '('.$f->size.')' if $f->size && |
217 | $f->data_type =~ /^(VAR)?CHAR2?$/i; |
ea93df61 |
218 | |
37503827 |
219 | my $nlen = length $name; |
60dcc980 |
220 | my $dlen = length $desc; |
f27f9229 |
221 | $max_name = $nlen if $nlen > ($max_name||0); |
222 | $max_desc = $dlen if $dlen > ($max_desc||0); |
60dcc980 |
223 | push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk, $attr ]; |
37503827 |
224 | } |
225 | |
60dcc980 |
226 | $max_name += 2; |
227 | $max_desc += 2; |
37503827 |
228 | for my $fld_desc ( @fld_desc ) { |
60dcc980 |
229 | my ( $name, $desc, $orig_name, $is_pk, $attr ) = @$fld_desc; |
230 | my $diff1 = $max_name - length $name; |
231 | my $diff2 = $max_desc - length $desc; |
232 | $name .= ' ' x $diff1; |
233 | $desc .= ' ' x $diff2; |
234 | $desc = $name . $desc . $attr; |
37503827 |
235 | |
236 | push @shapes, [ 'string', $font, $this_col_x, $y, $desc, 'black' ]; |
237 | $y += $font->height + 2; |
238 | my $length = $this_col_x + ( $font->width * length( $desc ) ); |
239 | $this_max_x = $length if $length > $this_max_x; |
240 | |
241 | my $constraints = $table->{'fields'}{ $orig_name }{'constraints'}; |
242 | |
9d4a26be |
243 | if ( $natural_join && !$skip_field{ $orig_name } ) { |
37503827 |
244 | push @{ $nj_registry{ $orig_name } }, $table_name; |
245 | } |
37503827 |
246 | |
247 | my $y_link = $y - $font->height/2; |
761fa621 |
248 | $coords{ $table_name }{ $orig_name }{'coords'} = { |
37503827 |
249 | left => [ $this_col_x - 6, $y_link ], |
250 | right => [ $length + 2 , $y_link ], |
251 | table => $table_name, |
252 | field_no => ++$field_no, |
253 | is_pk => $is_pk, |
254 | fld_name => $orig_name, |
255 | }; |
6a20798b |
256 | |
ea93df61 |
257 | push @imap_coords, [ |
6a20798b |
258 | $imap_url."#$table_name-$orig_name", |
259 | $this_col_x, $y - $font->height, $length, $y_link, |
260 | ]; |
37503827 |
261 | } |
262 | |
761fa621 |
263 | unless ( $natural_join ) { |
264 | for my $c ( $table->get_constraints ) { |
265 | next unless $c->type eq FOREIGN_KEY; |
266 | my $fk_table = $c->reference_table or next; |
267 | |
268 | for my $field_name ( $c->fields ) { |
269 | for my $fk_field ( $c->reference_fields ) { |
270 | next unless defined $schema->get_table( $fk_table ); |
271 | push @fk_registry, [ |
761fa621 |
272 | [ $fk_table , $fk_field ], |
761a28bb |
273 | [ $table_name, $field_name ], |
761fa621 |
274 | ]; |
275 | } |
276 | } |
277 | } |
278 | } |
279 | |
37503827 |
280 | $this_max_x += 5; |
281 | $table_x{ $table_name } = $this_max_x + 5; |
ea93df61 |
282 | push @shapes, [ 'line', $this_col_x - 5, $below_table_name, |
37503827 |
283 | $this_max_x, $below_table_name, 'black' ]; |
284 | my @bounds = ( $this_col_x - 5, $top - 5, $this_max_x, $y + 5 ); |
285 | if ( $add_color ) { |
ea93df61 |
286 | unshift @shapes, [ |
287 | 'filledRectangle', |
37503827 |
288 | $bounds[0], $bounds[1], |
289 | $this_max_x, $below_table_name, |
ea93df61 |
290 | 'khaki' |
37503827 |
291 | ]; |
292 | unshift @shapes, [ 'filledRectangle', @bounds, 'white' ]; |
293 | } |
6a20798b |
294 | |
ea93df61 |
295 | push @imap_coords, [ |
6a20798b |
296 | $imap_url."#$table_name", |
297 | $bounds[0], $bounds[1], $this_max_x, $below_table_name, |
298 | ]; |
299 | |
37503827 |
300 | push @shapes, [ 'rectangle', @bounds, 'black' ]; |
f27f9229 |
301 | $max_x = $this_max_x if $this_max_x > ($max_x||0); |
37503827 |
302 | $y += 25; |
ea93df61 |
303 | |
37503827 |
304 | if ( ++$no_this_col == $no_per_col ) {# if we've filled up this column |
305 | $cur_col++; # up the column number |
306 | $no_this_col = 0; # reset the number of tables |
307 | $max_x += $gutter; # push the x over for next column |
308 | $this_col_x = $max_x; # remember the max x for this col |
f27f9229 |
309 | $max_y = $y if $y > ($max_y||0); # note the max y |
37503827 |
310 | $y = $orig_y; # reset the y for next column |
311 | } |
312 | } |
313 | |
314 | # |
315 | # Connect the lines. |
316 | # |
317 | my %horz_taken; |
318 | my %done; |
319 | unless ( $no_lines ) { |
320 | my @position_bunches; |
321 | |
322 | if ( $natural_join ) { |
323 | for my $field_name ( keys %nj_registry ) { |
324 | my @positions; |
ea93df61 |
325 | my @table_names = |
37503827 |
326 | @{ $nj_registry{ $field_name } || [] } or next; |
327 | next if scalar @table_names == 1; |
328 | |
329 | for my $table_name ( @table_names ) { |
330 | push @positions, |
761fa621 |
331 | $coords{ $table_name }{ $field_name }{'coords'}; |
37503827 |
332 | } |
333 | |
334 | push @position_bunches, [ @positions ]; |
335 | } |
336 | } |
337 | else { |
338 | for my $pair ( @fk_registry ) { |
ea93df61 |
339 | push @position_bunches, [ |
761fa621 |
340 | $coords{$pair->[0][0]}{ $pair->[0][1] }{'coords'}, |
341 | $coords{$pair->[1][0]}{ $pair->[1][1] }{'coords'}, |
37503827 |
342 | ]; |
343 | } |
344 | } |
345 | |
346 | my $is_directed = $natural_join ? 0 : 1; |
347 | |
348 | for my $bunch ( @position_bunches ) { |
349 | my @positions = @$bunch; |
350 | |
351 | for my $i ( 0 .. $#positions ) { |
352 | my $pos1 = $positions[ $i ]; |
353 | my ( $ax, $ay ) = @{ $pos1->{'left'} || [] } or next; |
354 | my ( $bx, $by ) = @{ $pos1->{'right'} || [] } or next; |
355 | my $table1 = $pos1->{'table'}; |
356 | my $fno1 = $pos1->{'field_no'}; |
357 | my $is_pk = $pos1->{'is_pk'}; |
358 | next if $join_pk_only and !$is_pk; |
359 | |
360 | for my $j ( 0 .. $#positions ) { |
361 | my $pos2 = $positions[ $j ]; |
362 | my ( $cx, $cy ) = @{ $pos2->{'left'} || [] } or next; |
363 | my ( $dx, $dy ) = @{ $pos2->{'right'} || [] } or next; |
364 | my $table2 = $pos2->{'table'}; |
365 | my $fno2 = $pos2->{'field_no'}; |
366 | next if $table1 eq $table2; |
367 | next if $done{ $fno1 }{ $fno2 }; |
368 | next if $fno1 == $fno2; |
369 | |
370 | my @distances = (); |
371 | push @distances, [ |
372 | abs ( $ax - $cx ) + abs ( $ay - $cy ), |
373 | [ $ax, $ay, $cx, $cy ], |
374 | [ 'left', 'left' ] |
375 | ]; |
376 | push @distances, [ |
377 | abs ( $ax - $dx ) + abs ( $ay - $dy ), |
378 | [ $ax, $ay, $dx, $dy ], |
379 | [ 'left', 'right' ], |
380 | ]; |
381 | push @distances, [ |
382 | abs ( $bx - $cx ) + abs ( $by - $cy ), |
383 | [ $bx, $by, $cx, $cy ], |
384 | [ 'right', 'left' ], |
385 | ]; |
386 | push @distances, [ |
387 | abs ( $bx - $dx ) + abs ( $by - $dy ), |
388 | [ $bx, $by, $dx, $dy ], |
389 | [ 'right', 'right' ], |
390 | ]; |
391 | @distances = sort { $a->[0] <=> $b->[0] } @distances; |
392 | my $shortest = $distances[0]; |
393 | my ( $x1, $y1, $x2, $y2 ) = @{ $shortest->[1] }; |
394 | my ( $side1, $side2 ) = @{ $shortest->[2] }; |
395 | my ( $start, $end ); |
396 | my $offset = 9; |
397 | my $col1_right = $table_x{ $table1 }; |
398 | my $col2_right = $table_x{ $table2 }; |
399 | |
400 | my $diff = 0; |
401 | if ( $x1 == $x2 ) { |
402 | while ( $horz_taken{ $x1 + $diff } ) { |
ea93df61 |
403 | $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2; |
37503827 |
404 | } |
405 | $horz_taken{ $x1 + $diff } = 1; |
406 | } |
407 | |
408 | if ( $side1 eq 'left' ) { |
409 | $start = $x1 - $offset + $diff; |
410 | } |
411 | else { |
412 | $start = $col1_right + $diff; |
413 | } |
414 | |
415 | if ( $side2 eq 'left' ) { |
416 | $end = $x2 - $offset + $diff; |
ea93df61 |
417 | } |
37503827 |
418 | else { |
419 | $end = $col2_right + $diff; |
ea93df61 |
420 | } |
37503827 |
421 | |
ea93df61 |
422 | push @shapes, |
37503827 |
423 | [ 'line', $x1, $y1, $start, $y1, 'cadetblue' ]; |
ea93df61 |
424 | push @shapes, |
37503827 |
425 | [ 'line', $start, $y1, $end, $y2, 'cadetblue' ]; |
ea93df61 |
426 | push @shapes, |
37503827 |
427 | [ 'line', $end, $y2, $x2, $y2, 'cadetblue' ]; |
428 | |
429 | if ( $is_directed ) { |
430 | if ( |
431 | $side1 eq 'right' && $side2 eq 'left' |
432 | || |
433 | $side1 eq 'left' && $side2 eq 'left' |
434 | ) { |
ea93df61 |
435 | push @shapes, [ |
436 | 'line', $x2 - 3, $y2 - 3, $x2, $y2, 'cadetblue' |
37503827 |
437 | ]; |
ea93df61 |
438 | push @shapes, [ |
439 | 'line', $x2 - 3, $y2 + 3, $x2, $y2, 'cadetblue' |
37503827 |
440 | ]; |
ea93df61 |
441 | push @shapes, [ |
442 | 'line', $x2 - 3, $y2 - 3, $x2 - 3, $y2 +3, |
443 | 'cadetblue' |
37503827 |
444 | ]; |
445 | } |
446 | else { |
ea93df61 |
447 | push @shapes, [ |
448 | 'line', $x2 + 3, $y2 - 3, $x2, $y2, 'cadetblue' |
37503827 |
449 | ]; |
ea93df61 |
450 | push @shapes, [ |
451 | 'line', $x2 + 3, $y2 + 3, $x2, $y2, 'cadetblue' |
37503827 |
452 | ]; |
ea93df61 |
453 | push @shapes, [ |
454 | 'line', $x2 + 3, $y2 - 3, $x2 + 3, $y2 +3, |
455 | 'cadetblue' |
37503827 |
456 | ]; |
457 | } |
458 | } |
459 | |
460 | $done{ $fno1 }{ $fno2 } = 1; |
461 | $done{ $fno2 }{ $fno1 } = 1; |
462 | } |
463 | } |
464 | } |
465 | } |
466 | |
467 | # |
468 | # Add the title, legend and signature. |
469 | # |
470 | my $large_font = gdLargeFont; |
471 | my $title_len = $large_font->width * length $title; |
ea93df61 |
472 | push @shapes, [ |
473 | 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black' |
37503827 |
474 | ]; |
475 | |
476 | if ( %legend ) { |
477 | $max_y += 5; |
ea93df61 |
478 | push @shapes, [ |
37503827 |
479 | 'string', $font, $x, $max_y - $font->height - 4, 'Legend', 'black' |
480 | ]; |
481 | $max_y += $font->height + 4; |
482 | |
483 | my $longest; |
484 | for my $len ( map { length $_ } values %legend ) { |
f27f9229 |
485 | $longest = $len if $len > ($longest||0); |
37503827 |
486 | } |
487 | $longest += 2; |
488 | |
489 | while ( my ( $key, $shape ) = each %legend ) { |
490 | my $space = $longest - length $shape; |
ea93df61 |
491 | push @shapes, [ |
492 | 'string', $font, $x, $max_y - $font->height - 4, |
37503827 |
493 | join( '', $shape, ' ' x $space, $key ), 'black' |
494 | ]; |
495 | |
496 | $max_y += $font->height + 4; |
497 | } |
498 | } |
499 | |
60dcc980 |
500 | my $sig = 'Created by SQL::Translator ' . $t->version; |
37503827 |
501 | my $sig_len = $font->width * length $sig; |
ea93df61 |
502 | push @shapes, [ |
503 | 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4, |
37503827 |
504 | $sig, 'black' |
505 | ]; |
506 | |
507 | # |
508 | # Render the image. |
509 | # |
510 | my $gd = GD::Image->new( $max_x + 30, $max_y ); |
7652721a |
511 | unless ( $gd->can( $output_type ) ) { |
512 | die "GD can't create images of type '$output_type'\n"; |
37503827 |
513 | } |
514 | my %colors = map { $_->[0], $gd->colorAllocate( @{$_->[1]} ) } ( |
515 | [ white => [ 255, 255, 255 ] ], |
516 | [ beige => [ 245, 245, 220 ] ], |
517 | [ black => [ 0, 0, 0 ] ], |
518 | [ lightblue => [ 173, 216, 230 ] ], |
519 | [ cadetblue => [ 95, 158, 160 ] ], |
520 | [ lightgoldenrodyellow => [ 250, 250, 210 ] ], |
521 | [ khaki => [ 240, 230, 140 ] ], |
522 | [ red => [ 255, 0, 0 ] ], |
523 | ); |
524 | $gd->interlaced( 'true' ); |
525 | my $background_color = $add_color ? 'lightgoldenrodyellow' : 'white'; |
526 | $gd->fill( 0, 0, $colors{ $background_color } ); |
527 | for my $shape ( @shapes ) { |
528 | my $method = shift @$shape; |
529 | my $color = pop @$shape; |
530 | $gd->$method( @$shape, $colors{ $color } ); |
531 | } |
532 | |
533 | # |
6a20798b |
534 | # Make image map. |
535 | # |
536 | debug("imap file = '$imap_file'"); |
537 | if ( $imap_file && @imap_coords ) { |
d4924f25 |
538 | open my $fh, '>', $imap_file or die "Can't write '$imap_file': $!\n"; |
6a20798b |
539 | print $fh qq[<html><body><img src="" usemap="#imap" border="0">\n]. |
540 | qq[<map name="imap">\n]; |
541 | for my $rec ( @imap_coords ) { |
542 | my $href = shift @$rec; |
543 | print $fh q[<area coords="].join(',', @$rec).qq[" href="$href">\n]; |
ea93df61 |
544 | } |
6a20798b |
545 | print $fh qq[</body></html>]; |
546 | close $fh; |
547 | } |
548 | |
549 | # |
37503827 |
550 | # Print the image. |
551 | # |
552 | if ( $out_file ) { |
d4924f25 |
553 | open my $fh, '>', $out_file or die "Can't write '$out_file': $!\n"; |
54c61e72 |
554 | binmode $fh; |
7652721a |
555 | print $fh $gd->$output_type; |
37503827 |
556 | close $fh; |
557 | } |
558 | else { |
7652721a |
559 | return $gd->$output_type; |
37503827 |
560 | } |
561 | } |
562 | |
563 | 1; |
564 | |
565 | =pod |
566 | |
37503827 |
567 | =head1 AUTHOR |
568 | |
d4924f25 |
569 | Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>. |
37503827 |
570 | |
571 | =cut |