SWF::Chart - Perl interface to the SWF Chart generation tool

  use SWF::Chart;

  my $g = SWF::Chart->new;

  $g->set_titles(qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec));

  # Add a single data set
  $g->add_dataset(1, 3, 5, 7, 2, 4, 6);

  # Add multiple datasets
  $g->add_dataset([qw(1 3 5 7 11 13 17 23 29 31 37 41)],
                  [qw(1 1 2 3 5 8 13 21 34 55 89 144)]);

  # Add multiple datasets with labels
  $g->add_dataset('Label 1' => \@set1,
                  'Label 2' => \@set2);

  $g->text_properties(bold  => 0,
                      size  => 10,
                      color => '333333');

  $g->chart_rect(positive_color => '555555',
                 positive_alpha => 100);

  $g->series_color('DEADBE');

  print $g->xml;

  http://www.maani.us/charts/index.php?menu=Reference

  $g->chart_border(color            => '00FF00',
                   top_thickness    => 0,
                   bottom_thickness => 0);

  $g->chart_border(top_thickness    => 5,
                   bottom_thickness => 5);

package SWF::Chart;

#--------------------------------------#
# Dependencies

use strict;

#--------------------------------------#
# Global Variables

our $VERSION = '1.4';

# What version of the XML/SWF Charts flash module do we support?
our $SWF_VERSION = '4.5';

#--------------------------------------#
# Constants

# The OPTIONS hash keeps track of how all the options are represented in XML.
# If the first value is 'elem' it means that the option is a single element.
# For 'elem', if there is no second value, then that option is an empty content
# element that uses parameters, ie:
#
#   foobar => ['elem']
#
# and if the set call for this option looks like:
#
#   $g->foobar(param1 => 'value1', param2 => 'value2')
#
# then this XML will be produced:
#
#   <foobar param1="value1" param2="value2" />
#
# For 'elem', if the second value is 1, then the element has content, ie:
#
#   fizpow => ['elem', 1]
#
# and if the set call for this option looks like:
#
#   $g->fizpow('value')
#
# then this XML will be produced:
#
#   <fizpow>value</fizpow>
#
# If the first value if 'container' then the second value will be another option
# in OPTIONS that gives the format for the elements contained by this container.
# For example, if the option definition is:
#
#   mumblyjoe => ['container', 'fizpow']
#
# and if the set call for this option looks like:
#
#   $g->mumblyjoe('foo');
#   $g->mumblyjoe('bar');
#
# then this XML will be produced:
#
#   <mumblyjoe><fizpow>foo</fizpow><fizpow>bar</fizpow></mumblyjoe>
#
# To get different behavior, override the default AUTOLOAD method.

use constant OPTIONS => {
                         axis_category    => ['elem'],
                         axis_ticks       => ['elem'],
                         axis_value       => ['elem'],
                         axis_value_text  => ['container', 'string'],

                         chart_border     => ['elem'],
                         chart_data       => ['elem'],
                         chart_grid_h     => ['elem'],
                         chart_grid_v     => ['elem'],
                         chart_pref       => ['elem'],
                         chart_rect       => ['elem'],
                         chart_transition => ['elem'],
                         chart_type       => ['elem', 1],
                         chart_value      => ['elem'],
                         chart_value_text => ['container', 'string'],

                         legend_label      => ['elem'],
                         legend_rect       => ['elem'],
                         legend_transition => ['elem'],

                         link             => ['elem'],
                         link_data        => ['elem'],
                         live_update      => ['elem'],

                         series_color     => ['container', 'color'],
                         series_explode   => ['container', 'number'],
                         series_gap       => ['elem'],
                         series_switch    => ['elem'],

                         circle           => ['elem'],
                         line             => ['elem'],
                         rect             => ['elem'],
                         text             => ['elem'],
                         string           => ['elem', 1],
                         color            => ['elem', 1],
                         number           => ['elem', 1],
                        };

# A list of properties that if passed to any of the above options should be
# considered text properties.
use constant TEXT_PROPS => {font  => 1,
                            bold  => 1,
                            size  => 1,
                            color => 1,
                           };

#--------------------------------------#
# Public Class Methods

sub new {
    my $class = shift;
    my $self = bless {}, ref $class || $class;

    return $self;
}

sub DESTROY { }

#--------------------------------------#
# Public Instance Methods

sub set_titles {
    my $self = shift;
    my (@titles) = @_;

    # Allow either an array ref or an actual array to be passed in
    $self->{rows}->[0] = ref $titles[0] ? $titles[0] : \@titles;

    # Make sure to include the required empty cell for the title row
    unshift @{$self->{rows}->[0]},  undef;

    return 1;
}

sub add_dataset {
    my $self = shift;
    my (@set) = @_;

    # Initialize rows with a blank first row saved for the titles
    $self->{rows} ||= [undef];

    # Reformat to be in the form (label => \@row)
    if ($set[0] and ref $set[0]) {
        @set = map { undef, [@$_] } @set;
    } elsif ($set[1] and not ref $set[1]) {
        @set = (undef, [@set]);
    }

    while (@set) {
        my ($label, $r) = (shift @set, shift @set);

        # Add the label
        unshift @$r, $label;
        push @{$self->{rows}}, $r;
    }

    return 1;
}

sub chart_value_text {
    my $self = shift;
    my (@text) = @_;
    my @add_rows = ref $text[0] ? @text : (\@text);

    return unless @add_rows;

    my @rows = ['row', undef, [(['null']) x (scalar(@{$add_rows[0]})+1)]];
    my $data = $self->{opts}->{'chart_value_text'} ||=
               ['chart_value_text', undef, \@rows];

    foreach my $r (@add_rows) {
        my @str;
        push @{$data->[2]}, ['row', undef, \@str];

        foreach my $t (undef, @$r) {
            if (defined $t) {
                push @str, ['string', undef, $t];
            } else {
                push @str, ['null'];
            }
        }
    }

    return 1;
}

sub hide_legend {
    my $self = shift;

    # This is the ordained way to remove the legend...yuk
    $self->legend_rect(y => -9999);
}

sub text_properties {
    my $self = shift;
    my (%param) = @_;

    # Clean the values on the way in so we don't inadvertantly overwrite stuff
    foreach my $k (keys %param) {
        delete $param{$k} unless exists TEXT_PROPS->{$k};
    }
    $self->{defaults}->{text_props} = \%param;

    # Set the defaults for attribute only tags
    $self->axis_category(%param);
    $self->axis_value(%param);
    $self->chart_value(%param);
    $self->legend_label(%param);

    # Set the defaults for the draw_text tags
    if (exists $self->{opts}->{draw_text}) {

        # Get the array of <text> elements and loop through them
        my $text = $self->{opts}->{draw_text}->[2];
        foreach my $t (@$text) {

            # Iterate over each attribute currently set on this <text> element
            foreach my $k (keys %param) {

                # Update it unless its already set
                next if exists $t->[1]->{$k};
                $t->[1]->{$k} = $param{$k};
            }
        }
    }
}

sub draw {
    my $self = shift;
    my (%items) = @_;

    foreach my $type (keys %items) {
        my $opts  = $items{$type};
        my $value = $opts->{value};
        $value = delete $opts->{value} if $type eq 'text';
        $self->_draw_thing($type, $value, $opts);
    }
}

sub draw_circle { shift->_draw_thing('circle', undef, @_) }

sub draw_image  { shift->_draw_thing('image', undef, @_)  }

sub draw_line   { shift->_draw_thing('line', undef, @_)   }

sub draw_rect   { shift->_draw_thing('rect', undef, @_)   }

sub draw_text {
    my $self = shift;
    my ($text, %param) = @_;
    my $text_defaults = $self->{defaults}->{text_props};

    # If there are defaults copy them to the unset values
    if ($text_defaults) {
        foreach my $k (keys %$text_defaults) {
            next if exists $param{$k};
            $param{$k} = $text_defaults->{$k};
        }
    }

    $self->_draw_thing('text', $text, \%param);
}

sub _draw_thing {
    my $self = shift;
    my ($thing, $value) = (shift, shift);

    # Accept either a hash or a hash ref as the fourth arg of @_
    my $param = ref $_[0] ? $_[0] : {@_};
    my $data  = $self->{opts}->{draw} ||= ['draw', undef, []];

    if ($thing eq 'text') {
        push @{$data->[2]}, [$thing, $param, $value];
    } else {
        push @{$data->[2]}, [$thing, $param];
    }
}

use vars qw( $AUTOLOAD );
sub AUTOLOAD {
    my $obj = $_[0];
    (my $option = $AUTOLOAD) =~ s!.+::!!;
    no strict 'refs';

    my $type = OPTIONS->{$option};

    die "No such graph option '$option'" unless $type;

    if ($type->[0] eq 'elem') {
        # This type just sets a single value with no attributes
        if ($type->[1]) {
            *$AUTOLOAD = sub {
                my $self = shift;
                my ($value) = @_;
                $self->{opts}->{$option} = [$option, undef, $value];
            };
        }
        # This type just sets attributes with no value
        else {
            *$AUTOLOAD = sub {
                my $self = shift;
                my (%param) = @_;
                my $elem = $self->{opts}->{$option} ||= [$option, {}];

                # Update each attribute
                foreach my $k (keys %param) {
                    $elem->[1]->{$k} = $param{$k};
                }
            };
        }
    } elsif ($type->[0] eq 'container') {
        *$AUTOLOAD = sub {
            my $self = shift;
            my $data = $self->{opts}->{$option} ||= [$option, undef, []];

            push @{$data->[2]}, (@_ % 2 ? [$type->[1], undef, $_[0]]
                                        : [$type->[1], {@_}]);
        };
    }

    goto &$AUTOLOAD;
}

sub xml {
    my $self = shift;
    my (%param) = @_;
    my $format = $param{format} || 0;

    my $output = '<?xml version="1.0" encoding="utf-8"?><chart>';
    $output .= "\n" if $format;

    # Output all the chart preferences and settings
    foreach my $opt (keys %{$self->{opts}}) {
        $output .= $self->_elem_as_string($self->{opts}->{$opt});
        $output .= "\n" if $format;
    }

    # Output the data for this chart
    $output .= '<chart_data>';
    $output .= "\n" if $format;
    my $rows = $self->{rows};

    # Write the labels for the chart
    $output .= $self->_xml_chart_data_labels($rows->[0]);
    $output .= "\n" if $format;

    # Write the rows
    foreach my $r (@$rows[1..$#$rows]) {
        $output .= $self->_xml_chart_data_row($r);
        $output .= "\n" if $format;
    }

    $output .= '</chart_data>';
    $output .= "\n" if $format;

    $output .= '</chart>';

    return $output;
}

#--------------------------------------#
# Private Instance Methods

sub _xml_chart_data_labels {
    my $self = shift;
    my ($row) = @_;
    my $output = '<row><null/>';

    foreach my $t (@$row[1..$#$row]) {
        $output .= "<string>$t</string>";
    }

    $output .= '</row>';

    return $output;
}

sub _xml_chart_data_row {
    my $self = shift;
    my ($row) = @_;
    my $output = '<row>';

    if ($row->[0]) {
        $output .= '<string>'.$row->[0].'</string>';
    } else {
        $output .= '<null/>';
    }

    foreach my $n (@$row[1..$#$row]) {
        $n ||= '' unless defined $n;
        $output .= "<number>$n</number>";
    }

    $output .= '</row>';

    return $output;
}

# ['name', {param => 1}, [$child1, $child2, $child3]]
sub _elem_as_string {
    my $self = shift;
    my ($node) = @_;
    my ($name, $attr, $value) = @$node;
    my $out = "<$name";

    $out .= ' '.join(' ', map { $_.'="'.$attr->{$_}.'"' } keys %$attr) if $attr;

    if ($value) {
        $out .= '>';

        if (ref $value) {
            foreach my $child (@$value) {
                $out .= $self->_elem_as_string($child);
            }
        } else {
            $out .= $value;
        }

        $out .= "</$name>";
    } else {
        $out .= ' />';
    }

    return $out;
}

1;

__END__