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

#==========================================================================
#              Copyright (c) 1995-2000 Martien Verbruggen
#--------------------------------------------------------------------------
#
#   Name:
#       GD::Graph.pm
#
#   Description:
#       Module to create graphs from a data set drawing on a GD::Image
#       object
#
#       Package of a number of graph types:
#       GD::Graph::bars
#       GD::Graph::hbars
#       GD::Graph::lines
#       GD::Graph::points
#       GD::Graph::linespoints
#       GD::Graph::area
#       GD::Graph::pie
#       GD::Graph::mixed
#
# $Id: Graph.pm,v 1.55 2007/04/26 04:12:47 ben Exp $
#
#==========================================================================

#
# GD::Graph
#
# Parent class containing data all graphs have in common.
#

package GD::Graph;

($GD::Graph::prog_version) = '$Revision: 1.55 $' =~ /\s([\d.]+)/;
$GD::Graph::VERSION = '1.53';

use strict;
use GD;
use GD::Text::Align;
use GD::Graph::Data;
use GD::Graph::Error;
use Carp;

@GD::Graph::ISA = qw(GD::Graph::Error);

# Some tools and utils
use GD::Graph::colour qw(:colours);

my %GDsize = (
    'x' => 400,
    'y' => 300
);

my %Defaults = (

    # Set the top, bottom, left and right margin for the chart. These
    # margins will be left empty.
    t_margin      => 0,
    b_margin      => 0,
    l_margin      => 0,
    r_margin      => 0,

    # Set the factor with which to resize the logo in the chart (need to
    # automatically compute something nice for this, really), set the
    # default logo file name, and set the logo position (UR, BR, UL, BL)
    logo          => undef,
    logo_resize   => 1.0,
    logo_position => 'LR',

    # Do we want a transparent background?
    transparent   => 1,

    # Do we want interlacing?
    interlaced    => 1,

    # Set the background colour, the default foreground colour (used
    # for axes etc), the textcolour, the colour for labels, the colour
    # for numbers on the axes, the colour for accents (extra lines, tick
    # marks, etc..)
    bgclr         => 'white',   # background colour
    fgclr         => 'dblue',   # Axes and grid
    boxclr        => undef,     # Fill colour for box axes, default: not used
    accentclr     => 'gray',    # bar, area and pie outlines.

    labelclr      => 'dblue',   # labels on axes
    axislabelclr  => 'dblue',   # values on axes
    legendclr     => 'dblue',   # Text for the legend
    textclr       => 'dblue',   # All text, apart from the following 2

    valuesclr     => 'dblue',   # values printed above the points

    # data set colours
    dclrs => [qw(lred lgreen lblue lyellow lpurple cyan lorange)],

    # number of pixels to use as text spacing
    text_space    => 4,

    # These have undefined values, but are here so that the set method
    # knows about them:
    title       => undef,
);

sub _has_default {
    my $self = shift;
    my $attr = shift || return;
    exists $Defaults{$attr}
}

#
# PUBLIC methods, documented in pod.
#
sub new  # ( width, height ) optional;
{
    my $type = shift;
    my $self = {};
    bless $self, $type;

    if (@_)
    {
        # If there are any parameters, they should be the size
        return GD::Graph->_set_error(
            "Usage: GD::Graph::::new(width, height)") unless @_ >= 2;

        $self->{width} = shift;
        $self->{height} = shift;
    }
    else
    {
        # There were obviously no parameters, so use defaults
        $self->{width} = $GDsize{'x'};
        $self->{height} = $GDsize{'y'};
    }

    # Initialise all relevant parameters to defaults
    # These are defined in the subclasses. See there.
    $self->initialise() or return;

    return $self;
}

sub get
{
    my $self = shift;
    my @wanted = map $self->{$_}, @_;
    wantarray ? @wanted : $wanted[0];
}

sub set
{
    my $self = shift;
    my %args = @_;
    my $w = 0;

    foreach (keys %args)
    {
        # Enforce read-only attributes.
        /^width$/ || /^height$/ and do
        {
            $self->_set_warning("Read-only attribute '$_' not set");
            $w++;
            next;
        };

        $self->{$_} = $args{$_}, next if $self->_has_default($_);

        $w++;
        $self->_set_warning("No attribute '$_'");
    }

    return $w ? undef : "No problems";
}

# Generic routine to instantiate GD::Text::Align objects for text
# attributes
sub _set_font
{
    my $self = shift;
    my $name = shift;

    if (! exists $self->{$name})
    {
        $self->{$name} = GD::Text::Align->new($self->{graph},
            valign => 'top',
            halign => 'center',
        ) or return $self->_set_error("Couldn't set font");
    }

    $self->{$name}->set_font(@_);
}

sub set_title_font # (fontname, size)
{
    my $self = shift;
    $self->_set_font('gdta_title', @_);
}

sub set_text_clr # (colour name)
{
    my $self = shift;
    my $clr  = shift;

    $self->set(
        textclr       => $clr,
        labelclr      => $clr,
        axislabelclr  => $clr,
        valuesclr     => $clr,
    );
}

sub plot
{
    # ABSTRACT
    my $self = shift;
    $self->die_abstract("sub plot missing,");
}

# Set defaults that apply to all graph/chart types.
# This is called by the default initialise methods
# from the objects further down the tree.

sub initialise
{
    my $self = shift;

    foreach (keys %Defaults)
    {
        $self->set($_ => $Defaults{$_});
    }

    $self->open_graph()                     or return;
    $self->set_title_font(GD::Font->Large)  or return;
}


# Check the integrity of the submitted data
#
# Checks are done to assure that every input array
# has the same number of data points, it sets the variables
# that store the number of sets and the number of points
# per set, and kills the process if there are no datapoints
# in the sets, or if there are no data sets.

sub check_data # \@data
{
    my $self = shift;
    my $data = shift;

    $self->{_data} = GD::Graph::Data->new($data)
        or return $self->_set_error(GD::Graph::Data->error);

    $self->{_data}->make_strict;

    $self->{_data}->num_sets > 0 && $self->{_data}->num_points > 0
        or return $self->_set_error('No data sets or points');

    if ($self->{show_values})
    {
        # If this isn't a GD::Graph::Data compatible structure, then
        # we'll just use the data structure.
        #
        # XXX We should probably check a few more things here, e.g.
        # similarity between _data and show_values.
        #
        my $ref = ref($self->{show_values});
        if (! $ref || ($ref ne 'GD::Graph::Data' && $ref ne 'ARRAY'))
        {
            $self->{show_values} = $self->{_data}
        }
        elsif ($ref eq 'ARRAY')
        {
            $self->{show_values} =
                GD::Graph::Data->new($self->{show_values})
                or return $self->_set_error(GD::Graph::Data->error);
        }
    }

    return $self;
}

# Open the graph output canvas by creating a new GD object.

sub open_graph
{
    my $self = shift;
    return $self->{graph} if exists $self->{graph};
    $self->{graph} = 2.0 <= $GD::VERSION
        ?   GD::Image->newPalette($self->{width}, $self->{height})
        :   GD::Image->new($self->{width}, $self->{height});

}

# Initialise the graph output canvas, setting colours (and getting back
# index numbers for them) setting the graph to transparent, and
# interlaced, putting a logo (if defined) on there.

sub init_graph
{
    my $self = shift;

    $self->{bgci} = $self->set_clr(_rgb($self->{bgclr}));
    $self->{fgci} = $self->set_clr(_rgb($self->{fgclr}));
    $self->{tci}  = $self->set_clr(_rgb($self->{textclr}));
    $self->{lci}  = $self->set_clr(_rgb($self->{labelclr}));
    $self->{alci} = $self->set_clr(_rgb($self->{axislabelclr}));
    $self->{acci} = $self->set_clr(_rgb($self->{accentclr}));
    $self->{valuesci} = $self->set_clr(_rgb($self->{valuesclr}));
    $self->{legendci} = $self->set_clr(_rgb($self->{legendclr}));
    $self->{boxci} = $self->set_clr(_rgb($self->{boxclr}))
        if $self->{boxclr};

    $self->{graph}->transparent($self->{bgci}) if $self->{transparent};
    $self->{graph}->interlaced( $self->{interlaced} || undef ); # required by GD.pm

    # XXX yuck. This doesn't belong here.. or does it?
    $self->put_logo();

    return $self;
}

sub _read_logo_file
{
    my $self = shift;
    my $glogo;
    local (*LOGO);
    my $logo_path = $self->{logo};
    open(LOGO, $logo_path)
        or do { carp "Unable to open logo file '$logo_path': $!";return};
    binmode(LOGO);
    # if the file has an extension, use that importer
    my $gdimport;
    my @tried;
    # possibly forward-compatible: just try whatever file extension
    if ( $logo_path =~ /\.(\w+)$/i) {
        my $fmt = lc $1;
        $fmt = "jpeg" if 'jpg' eq $fmt;
        push @tried, uc $fmt;
        if ($gdimport = GD::Image->can("newFrom\u$fmt")) {
            if ('xpm' ne $fmt) { $glogo = GD::Image->$gdimport(\*LOGO) }
            else { $glogo = GD::Image->$gdimport($logo_path) } # quirky special case
        }
    }
    # if that didn't work, try using magic numbers
    if (!$glogo) {
        my $logodata;
        read LOGO,$logodata, -s LOGO;
        my %magic = (
            pack("H8",'ffd8ffe0') => "jpeg",
            'GIF8' => "gif",
            '.PNG' => "png",
            '/* X'=> "xpm", # technically '/* XPM */', but I'm hashing, here
        );
        if (my $match = $magic{ substr $logodata, 0, 4 }) {
            push @tried, $match;
            my $matchmethod = "newFrom\u$match";
            if ($gdimport = GD::Image->can($matchmethod . "Data")) {
                $glogo = GD::Image->$gdimport($logodata);
            } elsif ($gdimport = GD::Image->can($matchmethod)) {
                if ('xpm' eq $match) {
                    $glogo = GD::Image->$gdimport($logo_path);
                } else {
                    seek LOGO,0,0;
                    $glogo = GD::Image->$gdimport(\*LOGO);
                }
            }
        # should this actually be "if (!$glogo), rather than an else?
        } else { # Hail Mary, full of Grace!  Blessed art thou among women...
            push @tried, 'libgd best-guess';
            $glogo = GD::Image->new($logodata);
        }
    }
    close LOGO or croak "Unable to close logo file '$logo_path': $!";
    # XXX change to use warnings::enabled when we break 5.005 compatibility
    carp "Problems reading $logo_path (tried: @tried)" unless $glogo;
    return $glogo;
}

# read in the logo, and paste it on the graph canvas

sub put_logo
{
    my $self = shift;
    return unless defined $self->{logo};

    my $glogo = $self->_read_logo_file() or return;

    my ($x, $y);
    my $r = $self->{logo_resize};

    my $r_margin = (defined $self->{r_margin_abs}) ?
        $self->{r_margin_abs} : $self->{r_margin};
    my $b_margin = (defined $self->{b_margin_abs}) ?
        $self->{b_margin_abs} : $self->{b_margin};

    my ($w, $h) = $glogo->getBounds;
    LOGO: for ($self->{logo_position}) {
        /UL/i and do {
            $x = $self->{l_margin};
            $y = $self->{t_margin};
            last LOGO;
        };
        /UR/i and do {
            $x = $self->{width} - $r_margin - $w * $r;
            $y = $self->{t_margin};
            last LOGO;
        };
        /LL/i and do {
            $x = $self->{l_margin};
            $y = $self->{height} - $b_margin - $h * $r;
            last LOGO;
        };
        # default "LR"
        $x = $self->{width} - $r_margin - $r * $w;
        $y = $self->{height} - $b_margin - $r * $h;
        last LOGO;
    }
    $self->{graph}->copyResized($glogo,
        $x, $y, 0, 0, $r * $w, $r * $h, $w, $h);
}

# Set a colour to work with on the canvas, by rgb value.
# Return the colour index in the palette

sub set_clr # GD::Image, r, g, b
{
    my $self = shift;
    return unless @_;
    my $gd = $self->{graph};

    # All of this could potentially be done by using colorResolve
    # The problem is that colorResolve doesn't return an error
    # condition (-1) if it can't allocate a color. Instead it always
    # returns 0.

    # Check if this colour already exists on the canvas
    my $i = $gd->colorExact(@_);
    # if not, allocate a new one, and return its index
    $i = $gd->colorAllocate(@_) if $i < 0;
    # if this fails, we should use colorClosest.
    $i = $gd->colorClosest(@_)  if $i < 0;

    # TODO Deal with antialiasing here?
    if (0 && $self->can("setAntiAliased"))
    {
        $self->setAntiAliased($i);
        eval "$i = gdAntiAliased";
    }

    return $i;
}

# Set a temporary colour that can be used with fillToBorder
sub _set_tmp_clr
{
    my $self = shift;
    # XXX Error checks!
    $self->{graph}->colorAllocate(0,0,0);
}

# Remove the temporary colour
sub _rm_tmp_clr
{
    my $self = shift;
    return unless @_;
    # XXX Error checks?
    $self->{graph}->colorDeallocate(shift);
}

# Set a colour, disregarding wether or not it already exists. This may
# be necessary where one wants the same colour to have a different
# index, as in pie slices of the same color as the edge.
# Note that this could be cleaned up after needed, but we won't do that.

sub set_clr_uniq # GD::Image, r, g, b
{
    my $self = shift;
    return unless @_;
    $self->{graph}->colorAllocate(@_);
}

# Return an array of rgb values for a colour number

sub pick_data_clr # number
{
    my $self = shift;
    _rgb($self->{dclrs}[$_[0] % @{$self->{dclrs}} - 1]);
}

# contrib "Bremford, Mike"
sub pick_border_clr # number
{
    my $self = shift;

    ref $self->{borderclrs} ?
        _rgb($self->{borderclrs}[$_[0] % @{$self->{borderclrs}} - 1]) :
        _rgb($self->{accentclr});
}

sub gd
{
    my $self = shift;
    return $self->{graph};
}

sub export_format
{
    my $proto = shift;
    my @f = grep { GD::Image->can($_) &&
                   do {
                    my $g = GD::Image->new(5,5);
                    $g->colorAllocate(0,0,0);
                    $g->$_()
                   };
            } qw(gif png jpeg xbm xpm gd gd2);
    wantarray ? @f : $f[0];
}

# The following method is undocumented, and will not be supported as
# part of the interface. There isn't really much reason to do so.
sub import_format
{
    my $proto = shift;
    # xpm now included despite bugginess--should document the problem, though
    my @f = grep { GD::Image->can("newFrom\u$_") }
        qw(gif png jpeg xbm xpm gd gd2);
    wantarray ? @f : $f[0];
}

sub can_do_ttf
{
    my $proto = shift;
    return GD::Text->can_do_ttf;
}

# DEBUGGING
# data_dump obsolete now, use Data::Dumper

sub die_abstract
{
    my $self = shift;
    my $msg = shift;
    # ABSTRACT
    confess
        "Subclass (" .
        ref($self) .
        ") not implemented correctly: " .
        (defined($msg) ? $msg : "unknown error");
}

"Just another true value";

__END__