File Coverage

blib/lib/GD/Graph.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             #==========================================================================
2             # Copyright (c) 1995-2000 Martien Verbruggen
3             #--------------------------------------------------------------------------
4             #
5             # Name:
6             # GD::Graph.pm
7             #
8             # Description:
9             # Module to create graphs from a data set drawing on a GD::Image
10             # object
11             #
12             # Package of a number of graph types:
13             # GD::Graph::bars
14             # GD::Graph::hbars
15             # GD::Graph::lines
16             # GD::Graph::points
17             # GD::Graph::linespoints
18             # GD::Graph::area
19             # GD::Graph::pie
20             # GD::Graph::mixed
21             #
22             # $Id: Graph.pm,v 1.55 2007/04/26 04:12:47 ben Exp $
23             #
24             #==========================================================================
25              
26             #
27             # GD::Graph
28             #
29             # Parent class containing data all graphs have in common.
30             #
31              
32             package GD::Graph;
33              
34             ($GD::Graph::prog_version) = '$Revision: 1.55 $' =~ /\s([\d.]+)/;
35             $GD::Graph::VERSION = '1.53';
36              
37 4     4   5266 use strict;
  4         6  
  4         101  
38 4     4   2096 use GD;
  0            
  0            
39             use GD::Text::Align;
40             use GD::Graph::Data;
41             use GD::Graph::Error;
42             use Carp;
43              
44             @GD::Graph::ISA = qw(GD::Graph::Error);
45              
46             # Some tools and utils
47             use GD::Graph::colour qw(:colours);
48              
49             my %GDsize = (
50             'x' => 400,
51             'y' => 300
52             );
53              
54             my %Defaults = (
55              
56             # Set the top, bottom, left and right margin for the chart. These
57             # margins will be left empty.
58             t_margin => 0,
59             b_margin => 0,
60             l_margin => 0,
61             r_margin => 0,
62              
63             # Set the factor with which to resize the logo in the chart (need to
64             # automatically compute something nice for this, really), set the
65             # default logo file name, and set the logo position (UR, BR, UL, BL)
66             logo => undef,
67             logo_resize => 1.0,
68             logo_position => 'LR',
69              
70             # Do we want a transparent background?
71             transparent => 1,
72              
73             # Do we want interlacing?
74             interlaced => 1,
75              
76             # Set the background colour, the default foreground colour (used
77             # for axes etc), the textcolour, the colour for labels, the colour
78             # for numbers on the axes, the colour for accents (extra lines, tick
79             # marks, etc..)
80             bgclr => 'white', # background colour
81             fgclr => 'dblue', # Axes and grid
82             boxclr => undef, # Fill colour for box axes, default: not used
83             accentclr => 'gray', # bar, area and pie outlines.
84              
85             labelclr => 'dblue', # labels on axes
86             axislabelclr => 'dblue', # values on axes
87             legendclr => 'dblue', # Text for the legend
88             textclr => 'dblue', # All text, apart from the following 2
89              
90             valuesclr => 'dblue', # values printed above the points
91            
92             # data set colours
93             dclrs => [qw(lred lgreen lblue lyellow lpurple cyan lorange)],
94              
95             # number of pixels to use as text spacing
96             text_space => 4,
97              
98             # These have undefined values, but are here so that the set method
99             # knows about them:
100             title => undef,
101             );
102              
103             sub _has_default {
104             my $self = shift;
105             my $attr = shift || return;
106             exists $Defaults{$attr}
107             }
108              
109             #
110             # PUBLIC methods, documented in pod.
111             #
112             sub new # ( width, height ) optional;
113             {
114             my $type = shift;
115             my $self = {};
116             bless $self, $type;
117              
118             if (@_)
119             {
120             # If there are any parameters, they should be the size
121             return GD::Graph->_set_error(
122             "Usage: GD::Graph::::new(width, height)") unless @_ >= 2;
123              
124             $self->{width} = shift;
125             $self->{height} = shift;
126             }
127             else
128             {
129             # There were obviously no parameters, so use defaults
130             $self->{width} = $GDsize{'x'};
131             $self->{height} = $GDsize{'y'};
132             }
133              
134             # Initialise all relevant parameters to defaults
135             # These are defined in the subclasses. See there.
136             $self->initialise() or return;
137              
138             return $self;
139             }
140              
141             sub get
142             {
143             my $self = shift;
144             my @wanted = map $self->{$_}, @_;
145             wantarray ? @wanted : $wanted[0];
146             }
147              
148             sub set
149             {
150             my $self = shift;
151             my %args = @_;
152             my $w = 0;
153              
154             foreach (keys %args)
155             {
156             # Enforce read-only attributes.
157             /^width$/ || /^height$/ and do
158             {
159             $self->_set_warning("Read-only attribute '$_' not set");
160             $w++;
161             next;
162             };
163              
164             $self->{$_} = $args{$_}, next if $self->_has_default($_);
165              
166             $w++;
167             $self->_set_warning("No attribute '$_'");
168             }
169              
170             return $w ? undef : "No problems";
171             }
172              
173             # Generic routine to instantiate GD::Text::Align objects for text
174             # attributes
175             sub _set_font
176             {
177             my $self = shift;
178             my $name = shift;
179              
180             if (! exists $self->{$name})
181             {
182             $self->{$name} = GD::Text::Align->new($self->{graph},
183             valign => 'top',
184             halign => 'center',
185             ) or return $self->_set_error("Couldn't set font");
186             }
187              
188             $self->{$name}->set_font(@_);
189             }
190              
191             sub set_title_font # (fontname, size)
192             {
193             my $self = shift;
194             $self->_set_font('gdta_title', @_);
195             }
196              
197             sub set_text_clr # (colour name)
198             {
199             my $self = shift;
200             my $clr = shift;
201              
202             $self->set(
203             textclr => $clr,
204             labelclr => $clr,
205             axislabelclr => $clr,
206             valuesclr => $clr,
207             );
208             }
209              
210             sub plot
211             {
212             # ABSTRACT
213             my $self = shift;
214             $self->die_abstract("sub plot missing,");
215             }
216              
217             # Set defaults that apply to all graph/chart types.
218             # This is called by the default initialise methods
219             # from the objects further down the tree.
220              
221             sub initialise
222             {
223             my $self = shift;
224              
225             foreach (keys %Defaults)
226             {
227             $self->set($_ => $Defaults{$_});
228             }
229              
230             $self->open_graph() or return;
231             $self->set_title_font(GD::Font->Large) or return;
232             }
233              
234              
235             # Check the integrity of the submitted data
236             #
237             # Checks are done to assure that every input array
238             # has the same number of data points, it sets the variables
239             # that store the number of sets and the number of points
240             # per set, and kills the process if there are no datapoints
241             # in the sets, or if there are no data sets.
242              
243             sub check_data # \@data
244             {
245             my $self = shift;
246             my $data = shift;
247              
248             $self->{_data} = GD::Graph::Data->new($data)
249             or return $self->_set_error(GD::Graph::Data->error);
250            
251             $self->{_data}->make_strict;
252              
253             $self->{_data}->num_sets > 0 && $self->{_data}->num_points > 0
254             or return $self->_set_error('No data sets or points');
255            
256             if ($self->{show_values})
257             {
258             # If this isn't a GD::Graph::Data compatible structure, then
259             # we'll just use the data structure.
260             #
261             # XXX We should probably check a few more things here, e.g.
262             # similarity between _data and show_values.
263             #
264             my $ref = ref($self->{show_values});
265             if (! $ref || ($ref ne 'GD::Graph::Data' && $ref ne 'ARRAY'))
266             {
267             $self->{show_values} = $self->{_data}
268             }
269             elsif ($ref eq 'ARRAY')
270             {
271             $self->{show_values} =
272             GD::Graph::Data->new($self->{show_values})
273             or return $self->_set_error(GD::Graph::Data->error);
274             }
275             }
276              
277             return $self;
278             }
279              
280             # Open the graph output canvas by creating a new GD object.
281              
282             sub open_graph
283             {
284             my $self = shift;
285             return $self->{graph} if exists $self->{graph};
286             $self->{graph} = 2.0 <= $GD::VERSION
287             ? GD::Image->newPalette($self->{width}, $self->{height})
288             : GD::Image->new($self->{width}, $self->{height});
289              
290             }
291              
292             # Initialise the graph output canvas, setting colours (and getting back
293             # index numbers for them) setting the graph to transparent, and
294             # interlaced, putting a logo (if defined) on there.
295              
296             sub init_graph
297             {
298             my $self = shift;
299              
300             $self->{bgci} = $self->set_clr(_rgb($self->{bgclr}));
301             $self->{fgci} = $self->set_clr(_rgb($self->{fgclr}));
302             $self->{tci} = $self->set_clr(_rgb($self->{textclr}));
303             $self->{lci} = $self->set_clr(_rgb($self->{labelclr}));
304             $self->{alci} = $self->set_clr(_rgb($self->{axislabelclr}));
305             $self->{acci} = $self->set_clr(_rgb($self->{accentclr}));
306             $self->{valuesci} = $self->set_clr(_rgb($self->{valuesclr}));
307             $self->{legendci} = $self->set_clr(_rgb($self->{legendclr}));
308             $self->{boxci} = $self->set_clr(_rgb($self->{boxclr}))
309             if $self->{boxclr};
310              
311             $self->{graph}->transparent($self->{bgci}) if $self->{transparent};
312             $self->{graph}->interlaced( $self->{interlaced} || undef ); # required by GD.pm
313              
314             # XXX yuck. This doesn't belong here.. or does it?
315             $self->put_logo();
316              
317             return $self;
318             }
319              
320             sub _read_logo_file
321             {
322             my $self = shift;
323             my $glogo;
324             local (*LOGO);
325             my $logo_path = $self->{logo};
326             open(LOGO, $logo_path)
327             or do { carp "Unable to open logo file '$logo_path': $!";return};
328             binmode(LOGO);
329             # if the file has an extension, use that importer
330             my $gdimport;
331             my @tried;
332             # possibly forward-compatible: just try whatever file extension
333             if ( $logo_path =~ /\.(\w+)$/i) {
334             my $fmt = lc $1;
335             $fmt = "jpeg" if 'jpg' eq $fmt;
336             push @tried, uc $fmt;
337             if ($gdimport = GD::Image->can("newFrom\u$fmt")) {
338             if ('xpm' ne $fmt) { $glogo = GD::Image->$gdimport(\*LOGO) }
339             else { $glogo = GD::Image->$gdimport($logo_path) } # quirky special case
340             }
341             }
342             # if that didn't work, try using magic numbers
343             if (!$glogo) {
344             my $logodata;
345             read LOGO,$logodata, -s LOGO;
346             my %magic = (
347             pack("H8",'ffd8ffe0') => "jpeg",
348             'GIF8' => "gif",
349             '.PNG' => "png",
350             '/* X'=> "xpm", # technically '/* XPM */', but I'm hashing, here
351             );
352             if (my $match = $magic{ substr $logodata, 0, 4 }) {
353             push @tried, $match;
354             my $matchmethod = "newFrom\u$match";
355             if ($gdimport = GD::Image->can($matchmethod . "Data")) {
356             $glogo = GD::Image->$gdimport($logodata);
357             } elsif ($gdimport = GD::Image->can($matchmethod)) {
358             if ('xpm' eq $match) {
359             $glogo = GD::Image->$gdimport($logo_path);
360             } else {
361             seek LOGO,0,0;
362             $glogo = GD::Image->$gdimport(\*LOGO);
363             }
364             }
365             # should this actually be "if (!$glogo), rather than an else?
366             } else { # Hail Mary, full of Grace! Blessed art thou among women...
367             push @tried, 'libgd best-guess';
368             $glogo = GD::Image->new($logodata);
369             }
370             }
371             close LOGO or croak "Unable to close logo file '$logo_path': $!";
372             # XXX change to use warnings::enabled when we break 5.005 compatibility
373             carp "Problems reading $logo_path (tried: @tried)" unless $glogo;
374             return $glogo;
375             }
376              
377             # read in the logo, and paste it on the graph canvas
378              
379             sub put_logo
380             {
381             my $self = shift;
382             return unless defined $self->{logo};
383              
384             my $glogo = $self->_read_logo_file() or return;
385              
386             my ($x, $y);
387             my $r = $self->{logo_resize};
388              
389             my $r_margin = (defined $self->{r_margin_abs}) ?
390             $self->{r_margin_abs} : $self->{r_margin};
391             my $b_margin = (defined $self->{b_margin_abs}) ?
392             $self->{b_margin_abs} : $self->{b_margin};
393              
394             my ($w, $h) = $glogo->getBounds;
395             LOGO: for ($self->{logo_position}) {
396             /UL/i and do {
397             $x = $self->{l_margin};
398             $y = $self->{t_margin};
399             last LOGO;
400             };
401             /UR/i and do {
402             $x = $self->{width} - $r_margin - $w * $r;
403             $y = $self->{t_margin};
404             last LOGO;
405             };
406             /LL/i and do {
407             $x = $self->{l_margin};
408             $y = $self->{height} - $b_margin - $h * $r;
409             last LOGO;
410             };
411             # default "LR"
412             $x = $self->{width} - $r_margin - $r * $w;
413             $y = $self->{height} - $b_margin - $r * $h;
414             last LOGO;
415             }
416             $self->{graph}->copyResized($glogo,
417             $x, $y, 0, 0, $r * $w, $r * $h, $w, $h);
418             }
419              
420             # Set a colour to work with on the canvas, by rgb value.
421             # Return the colour index in the palette
422              
423             sub set_clr # GD::Image, r, g, b
424             {
425             my $self = shift;
426             return unless @_;
427             my $gd = $self->{graph};
428              
429             # All of this could potentially be done by using colorResolve
430             # The problem is that colorResolve doesn't return an error
431             # condition (-1) if it can't allocate a color. Instead it always
432             # returns 0.
433              
434             # Check if this colour already exists on the canvas
435             my $i = $gd->colorExact(@_);
436             # if not, allocate a new one, and return its index
437             $i = $gd->colorAllocate(@_) if $i < 0;
438             # if this fails, we should use colorClosest.
439             $i = $gd->colorClosest(@_) if $i < 0;
440              
441             # TODO Deal with antialiasing here?
442             if (0 && $self->can("setAntiAliased"))
443             {
444             $self->setAntiAliased($i);
445             eval "$i = gdAntiAliased";
446             }
447              
448             return $i;
449             }
450              
451             # Set a temporary colour that can be used with fillToBorder
452             sub _set_tmp_clr
453             {
454             my $self = shift;
455             # XXX Error checks!
456             $self->{graph}->colorAllocate(0,0,0);
457             }
458              
459             # Remove the temporary colour
460             sub _rm_tmp_clr
461             {
462             my $self = shift;
463             return unless @_;
464             # XXX Error checks?
465             $self->{graph}->colorDeallocate(shift);
466             }
467              
468             # Set a colour, disregarding wether or not it already exists. This may
469             # be necessary where one wants the same colour to have a different
470             # index, as in pie slices of the same color as the edge.
471             # Note that this could be cleaned up after needed, but we won't do that.
472              
473             sub set_clr_uniq # GD::Image, r, g, b
474             {
475             my $self = shift;
476             return unless @_;
477             $self->{graph}->colorAllocate(@_);
478             }
479              
480             # Return an array of rgb values for a colour number
481              
482             sub pick_data_clr # number
483             {
484             my $self = shift;
485             _rgb($self->{dclrs}[$_[0] % @{$self->{dclrs}} - 1]);
486             }
487              
488             # contrib "Bremford, Mike"
489             sub pick_border_clr # number
490             {
491             my $self = shift;
492              
493             ref $self->{borderclrs} ?
494             _rgb($self->{borderclrs}[$_[0] % @{$self->{borderclrs}} - 1]) :
495             _rgb($self->{accentclr});
496             }
497              
498             sub gd
499             {
500             my $self = shift;
501             return $self->{graph};
502             }
503              
504             sub export_format
505             {
506             my $proto = shift;
507             my @f = grep { GD::Image->can($_) &&
508             do {
509             my $g = GD::Image->new(5,5);
510             $g->colorAllocate(0,0,0);
511             $g->$_()
512             };
513             } qw(gif png jpeg xbm xpm gd gd2);
514             wantarray ? @f : $f[0];
515             }
516              
517             # The following method is undocumented, and will not be supported as
518             # part of the interface. There isn't really much reason to do so.
519             sub import_format
520             {
521             my $proto = shift;
522             # xpm now included despite bugginess--should document the problem, though
523             my @f = grep { GD::Image->can("newFrom\u$_") }
524             qw(gif png jpeg xbm xpm gd gd2);
525             wantarray ? @f : $f[0];
526             }
527              
528             sub can_do_ttf
529             {
530             my $proto = shift;
531             return GD::Text->can_do_ttf;
532             }
533              
534             # DEBUGGING
535             # data_dump obsolete now, use Data::Dumper
536              
537             sub die_abstract
538             {
539             my $self = shift;
540             my $msg = shift;
541             # ABSTRACT
542             confess
543             "Subclass (" .
544             ref($self) .
545             ") not implemented correctly: " .
546             (defined($msg) ? $msg : "unknown error");
547             }
548              
549             "Just another true value";
550              
551             __END__