File Coverage

blib/lib/Graphics/Primitive/Driver/GD.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Graphics::Primitive::Driver::GD;
2 1     1   22425 use Moose;
  0            
  0            
3              
4             our $VERSION = '0.01';
5              
6             use GD;
7             use Graphics::Primitive::Driver::GD::TextLayout;
8             use Math::Trig qw(rad2deg);
9              
10             with 'Graphics::Primitive::Driver';
11              
12             has 'current_x' => (
13             is => 'rw',
14             isa => 'Num',
15             default => 0
16             );
17              
18             has 'current_y' => (
19             is => 'rw',
20             isa => 'Num',
21             default => 0
22             );
23              
24             has 'fill_mode' => (
25             is => 'rw',
26             isa => 'Bool'
27             );
28              
29             has 'gd' => (
30             is => 'ro',
31             isa => 'GD::Image',
32             lazy_build => 1
33             );
34              
35             sub _finish_page {}
36             sub _resize {}
37             sub reset {}
38              
39             sub _build_gd {
40             my ($self) = @_;
41              
42             my $gd = GD::Image->new($self->width, $self->height, 1);
43             $gd->useFontConfig(1);
44             return $gd;
45             }
46              
47             before('draw', sub {
48             my ($self, $comp) = @_;
49              
50             my $o = $comp->origin;
51             $self->move_to($o->x, $o->y);
52             });
53              
54             sub data {
55             my ($self) = @_;
56              
57             # XX PNG only?
58             return $self->gd->png;
59             }
60              
61             sub convert_color {
62             my ($self, $color) = @_;
63              
64             return $self->gd->colorAllocateAlpha(
65             $color->red * 255,
66             $color->green * 255,
67             $color->blue * 255,
68             127 - ($color->alpha * 127)
69             );
70             }
71              
72             sub get_text_bounding_box {
73             my ($self, $tb, $text) = @_;
74              
75             my $gd = $self->gd;
76              
77             my $font = $tb->font;
78              
79             unless(defined($text)) {
80             $text = $tb->text;
81             }
82              
83             my @bounds = GD::Image->stringFT(
84             $self->convert_color($tb->color),
85             $font->face,
86             $font->size,
87             $tb->angle ? $tb->angle : 0,
88             0, 0,
89             $text
90             );
91              
92             my $tbr = Geometry::Primitive::Rectangle->new(
93             origin => Geometry::Primitive::Point->new(
94             x => 0,
95             y => 0,
96             ),
97             width => $bounds[4],
98             height => $bounds[1]
99             );
100              
101             my $cb = $tbr;
102              
103             return ($cb, $tbr);
104             }
105              
106             sub get_textbox_layout {
107             my ($self, $comp) = @_;
108              
109             my $tl = Graphics::Primitive::Driver::GD::TextLayout->new(
110             component => $comp
111             );
112             $tl->layout($self);
113             return $tl;
114             }
115              
116             sub move_to {
117             my ($self, $x, $y) = @_;
118              
119             $self->current_x($x);
120             $self->current_y($y);
121             }
122              
123             sub rel_move_to {
124             my ($self, $x, $y) = @_;
125              
126             $self->current_x($self->current_x + $x);
127             $self->current_y($self->current_y + $y);
128             }
129              
130             sub set_style {
131             my ($self, $brush) = @_;
132              
133             # Sets gdStyled to the dash pattern and sets the color
134             my $dash = $brush->dash_pattern;
135             my $color = $self->convert_color($brush->color);
136             $self->gd->setAntiAliased($color);
137             $self->gd->setThickness($brush->width);
138              
139             my @dash_style = ();
140             if(defined($dash) && scalar(@{ $dash })) {
141             foreach my $dc (@{ $dash }) {
142             for (0..$dc) {
143             # Try this?
144             # push(@dash_style, ($color) x $dc);
145             push(@dash_style, $color);
146             }
147             }
148             } else {
149             @dash_style = ( $color );
150             }
151             $self->gd->setStyle(@dash_style);
152             }
153              
154             sub write {
155             my ($self, $file) = @_;
156              
157             my $fh = IO::File->new($file, 'w')
158             or die("Unable to open '$file' for writing: $!");
159             $fh->binmode;
160             $fh->print($self->data);
161             $fh->close;
162             }
163              
164             sub _do_stroke {
165             my ($self, $op) = @_;
166              
167             my $gd = $self->gd;
168             $self->fill_mode(0);
169              
170             $self->set_style($op->brush);
171             }
172              
173             sub _do_fill {
174             my ($self, $op) = @_;
175             $self->fill_mode(1);
176              
177             # XX Only works for Solid...
178             $self->set_style(Graphics::Primitive::Brush->new(
179             color => $op->paint->color,
180             ));
181             }
182              
183             sub _draw_arc {
184             my ($self, $comp) = @_;
185              
186             # No stroke!
187             my $gd = $self->gd;
188             if($self->fill_mode) {
189             $gd->filledArc(
190             $self->current_x, $self->current_y, $comp->radius, $comp->radius,
191             rad2deg($comp->angle_start), rad2deg($comp->angle_end), gdStyled
192             );
193             } else {
194             $gd->arc(
195             $self->current_x, $self->current_y, $comp->radius, $comp->radius,
196             rad2deg($comp->angle_start), rad2deg($comp->angle_end), gdStyled
197             );
198             }
199             }
200              
201             sub _draw_bezier {
202             my ($self, $bezier) = @_;
203              
204             my $context = $self->cairo;
205             my $start = $bezier->start;
206             my $end = $bezier->end;
207             my $c1 = $bezier->control1;
208             my $c2 = $bezier->control2;
209              
210             $context->curve_to($c1->x, $c1->y, $c2->x, $c2->y, $end->x, $end->y);
211             }
212              
213             sub _draw_canvas {
214             my ($self, $comp) = @_;
215              
216             $self->_draw_component($comp);
217              
218             foreach (@{ $comp->paths }) {
219             $self->_draw_path($_->{path}, $_->{op});
220             }
221             }
222              
223             sub _draw_circle {
224             my ($self, $comp) = @_;
225              
226             # No stroke!
227             my $gd = $self->gd;
228             if($self->fill_mode) {
229             $gd->filledEllipse(
230             $self->current_x, $self->current_y, $comp->radius, $comp->radius,
231             gdStyled
232             );
233             } else {
234             $gd->ellipse(
235             $self->current_x, $self->current_y, $comp->radius, $comp->radius,
236             gdStyled
237             );
238             }
239             }
240              
241             sub _draw_component {
242             my ($self, $comp) = @_;
243              
244             my $gd = $self->gd;
245              
246             my $bc = $comp->background_color;
247             if(defined($bc)) {
248             my ($mt, $mr, $mb, $ml) = $comp->margins->as_array;
249             # GD's alpha is backward from Graphics::Color::RGB's...
250             my $color = $self->convert_color($bc);
251             $self->rel_move_to($mr, $mt);
252              
253             $gd->filledRectangle(
254             $self->current_x,
255             $self->current_y,
256             $self->current_x + $comp->width - $ml - $mr - 1,
257             $self->current_y + $comp->height - $mb - $mt - 1,
258             $color
259             );
260             }
261              
262             my $border = $comp->border;
263             if(defined($border)) {
264             if($border->homogeneous) {
265             if($border->top->width) {
266             $self->_draw_simple_border($comp);
267             }
268             } else {
269             $self->_draw_complex_border($comp);
270             }
271             }
272             }
273              
274             sub _draw_complex_border {
275             my ($self, $comp) = @_;
276              
277             my ($mt, $mr, $mb, $ml) = $comp->margins->as_array;
278              
279             my $gd = $self->gd;
280             my $border = $comp->border;
281              
282             my $width = $comp->width;
283             my $height = $comp->height;
284              
285             my $bt = $border->top;
286             my $thalf = (defined($bt) && defined($bt->color))
287             ? $bt->width / 2: 0;
288              
289             my $br = $border->right;
290             my $rhalf = (defined($br) && defined($br->color))
291             ? $br->width / 2: 0;
292              
293             my $bb = $border->bottom;
294             my $bhalf = (defined($bb) && defined($bb->color))
295             ? $bb->width / 2 : 0;
296              
297             my $bl = $border->left;
298             my $lhalf = (defined($bl) && defined($bl->color))
299             ? $bl->width / 2 : 0;
300              
301             if($thalf) {
302             $self->set_style($bt);
303             $gd->line(
304             $self->current_x,
305             $self->current_y + $thalf,
306             $self->current_x + $width - $mr - $ml - 1,
307             $self->current_y + $thalf,
308             gdStyled
309             );
310             }
311              
312             if($rhalf) {
313             $self->set_style($br);
314             $gd->line(
315             $self->current_x + $width - $mr - $ml - $rhalf,
316             $self->current_y,
317             $self->current_x + $width - $mr - $ml - $rhalf,
318             $self->current_y + $height - $mb - $mt - 1,
319             gdStyled
320             );
321             }
322              
323             if($bhalf) {
324             $self->set_style($bb);
325             $gd->line(
326             $self->current_x + $width - $mr - $ml - 1,
327             $self->current_y + $height - $mb - $mt - $bhalf,
328             $self->current_x,
329             $self->current_y + $height - $mb - $mt - $bhalf,
330             gdStyled
331             );
332             }
333              
334             if($lhalf) {
335             $self->set_style($bl);
336             $gd->line(
337             $self->current_x + $lhalf,
338             $self->current_y,
339             $self->current_x + $lhalf,
340             $self->current_y + $height - $mt - $mb - 1,
341             gdStyled
342             );
343             }
344             }
345              
346             sub _draw_ellipse {
347             my ($self, $comp) = @_;
348              
349             # No stroke!
350             my $gd = $self->gd;
351             if($self->fill_mode) {
352             $gd->filledEllipse(
353             $self->current_x, $self->current_y, $comp->width, $comp->height,
354             gdStyled
355             );
356             } else {
357             $gd->ellipse(
358             $self->current_x, $self->current_y, $comp->width, $comp->height,
359             gdStyled
360             );
361             }
362             }
363              
364             sub _draw_line {
365             my ($self, $line) = @_;
366              
367             my $gd = $self->gd;
368              
369             my $end = $line->end;
370             $gd->line($self->current_x, $self->current_y, $end->x, $end->y, gdStyled);
371             }
372              
373             sub _draw_path {
374             my ($self, $path, $op) = @_;
375              
376             my $gd = $self->gd;
377              
378             if($op->isa('Graphics::Primitive::Operation::Stroke')) {
379             $self->_do_stroke($op);
380             } elsif($op->isa('Graphics::Primitive::Operation::Fill')) {
381             $self->_do_fill($op);
382             }
383              
384              
385             # If preserve count is set we've "preserved" a path that's made up
386             # of X primitives. Set the sentinel to the the count so we skip that
387             # many primitives
388             # my $pc = $self->_preserve_count;
389             # if($pc) {
390             # $self->_preserve_count(0);
391             # } else {
392             # $context->new_path;
393             # }
394              
395             my $pcount = $path->primitive_count;
396             for(my $i = 0; $i < $pcount; $i++) {
397             my $prim = $path->get_primitive($i);
398             my $hints = $path->get_hint($i);
399              
400             if(defined($hints)) {
401             unless($hints->{contiguous}) {
402             my $ps = $prim->point_start;
403             $self->move_to($ps->x, $ps->y);
404             }
405             }
406              
407             # FIXME Check::ISA
408             if($prim->isa('Geometry::Primitive::Line')) {
409             $self->_draw_line($prim);
410             } elsif($prim->isa('Geometry::Primitive::Rectangle')) {
411             $self->_draw_rectangle($prim);
412             } elsif($prim->isa('Geometry::Primitive::Arc')) {
413             $self->_draw_arc($prim);
414             } elsif($prim->isa('Geometry::Primitive::Bezier')) {
415             $self->_draw_bezier($prim);
416             } elsif($prim->isa('Geometry::Primitive::Circle')) {
417             $self->_draw_circle($prim);
418             } elsif($prim->isa('Geometry::Primitive::Ellipse')) {
419             $self->_draw_ellipse($prim);
420             } elsif($prim->isa('Geometry::Primitive::Polygon')) {
421             $self->_draw_polygon($prim);
422             }
423             }
424              
425             if($op->preserve) {
426             $self->_preserve_count($path->primitive_count);
427             }
428             }
429              
430             sub _draw_polygon {
431             my ($self, $comp) = @_;
432              
433             my $gd = $self->gd;
434             my $poly = GD::Polygon->new;
435             for(my $i = 1; $i < $poly->point_count; $i++) {
436             my $p = $poly->get_point($i);
437             $poly->addPto($p->x, $p->y);
438             }
439             if($self->fill_mode) {
440             $gd->filledPolygon($poly, gdStyled);
441             } else {
442             $gd->openPolygon($poly, gdStyled);
443             }
444             }
445              
446             sub _draw_rectangle {
447             my ($self, $comp) = @_;
448              
449             my $gd = $self->gd;
450             if($self->fill_mode) {
451             $gd->filledRectangle(
452             $comp->origin->x, $comp->origin->y,
453             $comp->origin->x + $comp->width, $comp->origin->y + $comp->height
454             );
455             } else {
456             $gd->rectangle(
457             $comp->origin->x, $comp->origin->y,
458             $comp->origin->x + $comp->width, $comp->origin->y + $comp->height
459             );
460             }
461             }
462              
463             sub _draw_simple_border {
464             my ($self, $comp) = @_;
465              
466             my $gd = $self->gd;
467              
468             my $border = $comp->border;
469             my $top = $border->top;
470             my $bswidth = $top->width;
471              
472             my $c = $comp->border->top->color;
473             my $color = $gd->colorAllocateAlpha(
474             $c->red * 255, $c->green * 255, $c->blue * 255, 127 - ($c->alpha * 127)
475             );
476              
477             my @margins = $comp->margins->as_array;
478              
479             $gd->setThickness($bswidth);
480              
481             my $swhalf = $bswidth / 2;
482             my $width = $comp->width;
483             my $height = $comp->height;
484             my $mx = $margins[3];
485             my $my = $margins[1];
486              
487             $self->set_style($top);
488              
489             $self->rel_move_to($margins[3], $margins[0]);
490             $gd->rectangle(
491             $self->current_x + $swhalf,
492             $self->current_y + $swhalf,
493             $self->current_x + $width - $bswidth - $margins[1] + $swhalf,
494             $self->current_y + $height - $bswidth - $margins[0] + $swhalf,
495             gdStyled
496             );
497             }
498              
499             sub _draw_textbox {
500             my ($self, $comp) = @_;
501              
502             return unless defined($comp->text);
503              
504             $self->_draw_component($comp);
505              
506             my $bbox = $comp->inside_bounding_box;
507              
508             my $height = $bbox->height;
509             my $height2 = $height / 2;
510             my $width = $bbox->width;
511             my $width2 = $width / 2;
512              
513             my $halign = $comp->horizontal_alignment;
514             my $valign = $comp->vertical_alignment;
515              
516             my $gd = $self->gd;
517              
518             my $font = $comp->font;
519             my $fsize = $font->size;
520              
521             my $lh = $comp->line_height;
522             $lh = $fsize unless(defined($lh));
523              
524             my $yaccum = $bbox->origin->y;
525              
526             foreach my $line (@{ $comp->layout->lines }) {
527             my $text = $line->{text};
528             my $tbox = $line->{box};
529              
530             my $o = $tbox->origin;
531             my $bbo = $bbox->origin;
532             my $twidth = $tbox->width;
533             my $theight = $tbox->height;
534              
535             my $x = $bbox->origin->x + $o->x;
536              
537             my $ydiff = $theight + $o->y;
538             my $xdiff = $twidth + $o->x;
539              
540             my $realh = $theight + $ydiff;
541             my $realw = $twidth + $xdiff;
542             my $theight2 = $realh / 2;
543             my $twidth2 = $twidth / 2;
544              
545             my $y = $yaccum + $theight;
546              
547             if($halign eq 'right') {
548             $x += $width - $twidth;
549             } elsif($halign eq 'center') {
550             $x += $width2 - $twidth2;
551             }
552              
553             if($valign eq 'bottom') {
554             $y = $height - $ydiff;
555             } elsif($valign eq 'center') {
556             $y += $height2 - $theight2;
557             } else {
558             $y += $lh;
559             }
560              
561             $gd->stringFT(
562             gdStyled,
563             # $self->convert_color($comp->color),
564             $font->face,
565             $fsize,
566             $comp->angle ? $comp->angle : 0,
567             $x, $y,
568             $text
569             );
570              
571             $yaccum += $lh;
572             }
573             }
574              
575             __PACKAGE__->meta->make_immutable;
576              
577             1;
578              
579             =head1 NAME
580              
581             Graphics::Primitive::Driver::GD - GD driver for Graphics::Primitive
582              
583             =head1 SYNOPSIS
584              
585             use Graphics::Primitive::Component;
586             use Graphics::Primitive::Driver::GD;
587              
588             my $container = Graphics::Primitive::Container->new(
589             width => $form->sheet_width,
590             height => $form->sheet_height
591             );
592             $container->border->width(1);
593             $container->border->color($black);
594             $container->padding(
595             Graphics::Primitive::Insets->new(top => 5, bottom => 5, left => 5, right => 5)
596             );
597             my $comp = Graphics::Primitive::Component->new;
598             $comp->background_color($black);
599             $container->add_component($comp, 'c');
600              
601             my $lm = Layout::Manager::Compass->new;
602             $lm->do_layout($container);
603              
604             my $driver = Graphics::Primitive::Driver::GD->new;
605             $driver->draw($container);
606             $driver->write('/Users/gphat/foo.png');
607              
608             =head1 WARNING
609              
610             This module is in it's early stages and does not work properly. It will be
611             improved shortly.
612              
613             =head1 AUTHOR
614              
615             Cory G Watson, C<< <gphat at cpan.org> >>
616              
617             =head1 ACKNOWLEDGEMENTS
618              
619             =head1 COPYRIGHT & LICENSE
620              
621             Copyright 2009 Cory G Watson.
622              
623             This program is free software; you can redistribute it and/or modify it
624             under the terms of either: the GNU General Public License as published
625             by the Free Software Foundation; or the Artistic License.
626              
627             See http://dev.perl.org/licenses/ for more information.