DBD-Chart
view release on metacpan or search on metacpan
#23456789012345678901234567890123456789012345678901234567890123456789012345
#
# Copyright (c) 2001-2006, Dean Arnold
#
# You may distribute under the terms of the Artistic License, as
# specified in the Perl README file.
#
# History:
#
# 0.82 2006-May-20 D. Arnold
# update to support unexecuted sth's via
# DBIx::Chart::SthContainer objects
# fix uninit value warning in X_ORIENT check
#
# 0.81 2005-Jan-26 D. Arnold
# converted to DBI::set_err for improved error reporting
# modified prepare() regex to handle trailing whitespace
#
# 0.80 2002-Sep-13 D. Arnold
# enhanced syntax in support of DBIx::Chart
# programmable fonts
# added chart_type_map to permit external
# type specs for parameterized datasources
# add BORDER property
#
# 0.73 2002-Sep-11 D. Arnold
# fix error reporting from ::Plot
# fix the SYNOPSIS
#
# 0.72 2002-Aug-17 D. Arnold
# fix legend placement
#
# 0.71 2002-Aug-12 D. Arnold
# fix LINEWIDTH property to be local
# add ANCHORED property
# fixed VERSION value
#
# 0.70 2002-Jun-01 D. Arnold
# added quadtree plots
# added cumulative (aka stacked) barcharts
# fix for individual graph SHOWVALUES
# added support for official DBI array binding
# added LINEWIDTH property
# added chart_map_modifier attribute
# added installation tests
#
# 0.63 2002-May-16 D. Arnold
# Fix for Gantt date axis alignment
#
# 0.62 2002-Apr-22 D. Arnold
# Fix for numeric month validation
#
# 0.61 2001-Mar-14 D. Arnold
# Fix for multicolor histos
# Replace hyphenated properties with
# underscores
# Support quoted color and shape names
# Support IN (...) syntax for color, shape, and icon lists
# added 'dot' shape (contributed by Andrea Spinelli)
#
# 0.60 2001-Jan-12 D. Arnold
# Temporal datatypes
# Appl. defined colors
# Histograms
# composite images (derived tables)
# Gantt charts
#
# 0.52 2001-Dec-14 D. Arnold
# Fixed 2-D barchart crashes
#
# 0.51 2001-Dec-01 D. Arnold
# Support multicolor single range barcharts
# Support for 3D piecharts
# Support for temporal datatypes
#
# 0.50 2001-Oct-29 D. Arnold
# Add ICON(ICONS) property
# Add COLORS synonym
# Add FONT property
# Add GRIDCOLOR property
# Add TEXTCOLOR property
# Add Z-AXIS property
# Add IMAGEMAP output type
#
# 0.43 2001-Oct-11 P. Scott
# Allow a 'gif' (or any future format supported by
# GD::Image) FORMAT and GIF logos, added use Carp.
#
# 0.42 2001-Sep-29 D. Arnold
# fix to support X-ORIENT='HORIZONTAL' on candlestick and
# symbolic domains
$t = $$data[$i];
splice(@$t, $k, 1);
}
}
return $j;
}
#
# must be SELECT, so render the chart
#
my $dtypes = $sth->{chart_charttypes};
my $dcharts = $sth->{chart_sources};
my $dprops = $sth->{chart_properties};
my $dversions = $sth->{chart_version};
my $dcols = $sth->{chart_columns};
my $dnames = $sth->{chart_qnames};
my $srcsth;
my @dcolidxs = ();
#
# if COLORMAP, just fetch and return
#
if ($$dcharts[0] && ($$dcharts[0] eq 'COLORMAP')) {
my $table = $DBD::Chart::charts{COLORMAP};
my $col1 = $table->{data}->[0];
if (defined($$props{NAME})) {
#
# selecting single color, setup for the fetch
#
if ($$props{NAME}=~/^\?(\d+)$/) {
my $phnum = $1;
return $sth->DBI::set_err(-1, 'Insufficient parameters provided.', 'S1000')
if ($phnum > scalar(@$parms));
$sth->{chart_colormap} = $$parms[$phnum];
}
else {
$sth->{chart_colormap} = $$props{NAME};
}
my $color;
foreach $color (@$col1) {
last if ($color eq $sth->{chart_colormap});
}
return '0E0' if ($color ne $sth->{chart_colormap});
$sth->{chart_1_color} = 1;
return 1;
}
#
# selecting all colors
#
delete $sth->{chart_1_color};
$sth->{chart_colormap} = 0;
return scalar @$col1;
}
#
# now we can safely process and render
#
my $img;
my $xdomain;
my $ydomain;
my $zdomain;
my @legends = ();
#
# need to determine domain type prior to adding points
my $is_symbolic = undef;
for ($i = 0; $i < scalar(@$dtypes); $i++) {
$is_symbolic = 1, last
if (($$dtypes[$i] eq 'BARCHART') ||
($$dtypes[$i] eq 'HISTOGRAM') ||
($$dtypes[$i] eq 'CANDLESTICK'));
}
for ($i = 0; $i < scalar(@$dtypes); $i++) {
if ($$dtypes[$i] ne 'IMAGE') {
$name = $$dcharts[$i];
next unless (($i > 0) || $name); # for composite images
$srcsth = undef;
if ($name!~/^\?(\d+)$/) {
#
# its a local temp table
#
$chart = $DBD::Chart::charts{$name};
return $sth->DBI::set_err(-1, "Chart $name does not exist.", 'S1000')
unless $chart;
return $sth->DBI::set_err(-1, "Prepared version of $name differs from current version.", 'S1000')
if ($$chart{version} != $$dversions{$name});
$chart = $DBD::Chart::charts{$$dcharts[$i]};
#
# get the record description
#
$columns = $$chart{columns};
$types = $$chart{types};
$precs = $$chart{precisions};
$scales = $$chart{scales};
$data = $$chart{data};
}
else { # its a parameterized chartsource
my $phn = $1;
return $sth->DBI::set_err(-1, 'Parameterized chartsource not provided.','S1000')
unless $$parms[$phn];
#
# DAA 2006-05-20 change to support execution of sth if its a DBIx::Chart::SthContainer
#
$srcsth = $$parms[$phn];
return $sth->DBI::set_err(-1,
'Parameterized chartsource value must be a prepared and executed DBI statement handle.','S1000')
# if ((ref $srcsth ne 'DBI::st') && (ref $srcsth ne 'DBIx::Chart::st'));
if ((ref $srcsth ne 'DBI::st') && (ref $srcsth ne 'DBIx::Chart::SthContainer'));
#
# if its an unexecuted container, we must execute *before* testing metadata
# (some DBD's don't have metadata until they're executed)
#
my $ctype = $$dtypes[$i];
my $numflds;
if (ref $srcsth eq 'DBIx::Chart::SthContainer') {
return undef
# Piechart:
# first data array is domain names, the 2nd is the
# datasets. If more than 1 dataset is supplied, the
# rest are ignored
#
if ($$dtypes[$i] eq 'PIECHART') {
$propstr = 'pie ' . join(' ', @colors);
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints($$data[0], $$data[1], $propstr);
next;
}
#
# Quadtree:
# 1st N-2 data arrays are categories, in a category hierarchy,
# data array N-1 is the values assigned to the individual items,
# data array N is the intensity values of individual items
#
if ($$dtypes[$i] eq 'QUADTREE') {
$propstr = 'quadtree ' . join(' ', @colors);
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints(@$data, $propstr);
next;
}
#
# Gantt chart:
# first data array is task names, 2nd is the start date,
# 3rd is end date. Add'l optionals are assignee, pct. complete,
# and any number of dependent tasks
#
if ($$dtypes[$i] eq 'GANTT') {
$propstr = "gantt $colors[0]";
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints(@$data, $propstr);
next;
}
#
# need column names in defined order
#
my @colnames = ();
if (! $srcsth) {
$colnames[$$columns{$_}] = $_
foreach (keys(%$columns));
}
else {
@colnames = @$columns;
}
shift @colnames unless ($$dtypes[$i] eq 'BOXCHART');
$propstr .= ' showvalues:' . (($$props{SHOWVALUES} == 1) ? 5 : $$props{SHOWVALUES}) . ' '
if ($$props{SHOWVALUES});
$propstr .= ' stack '
if ($$props{STACK});
#
# default x-axis label orientation is vertical for candlesticks
# and symbollic domains
#
$img->setOptions(
'xAxisVert' => ($$props{X_ORIENT} ? ($$props{X_ORIENT} ne 'HORIZONTAL') : 1))
if ((! $numtype{$$types[0]}) || ($$dtypes[$i] eq 'CANDLESTICK'));
#
# force a legend if more than 1 range or plot
# complicated algorithm here;
# if multirange or composite {
# if multirange {
# push each column name onto legends array, prepended with
# current query name if available
# }
# } else { must be a composite
# push query name (default PLOTn) onto legends array
# }
#
if (! $$props{Z_AXIS}) {
if ((($$dtypes[$i] ne 'CANDLESTICK') && (scalar(@$data) > 2)) ||
(($$dtypes[$i] eq 'BOXCHART') && (scalar(@$data) > 1)) ||
(scalar(@$data) > 3)) {
# its multirange
my $incr = ($$dtypes[$i] ne 'CANDLESTICK') ? 1 : 2;
# if stacked, we need an arrayref of legends
my $legary = ($$props{STACK}) ? [ ] : \@legends;
push(@legends, $legary) if ($$props{STACK});
for (my $c = 0; $c <= $#colnames; $c += $incr) {
#
# if floating bar/histo, ignore last column name
last if ((! $$props{ANCHORED}) && ($c == $#colnames) &&
(($$dtypes[$i] eq 'BARCHART') ||
($$dtypes[$i] eq 'HISTOGRAM')));
#
# prepend query names if provided for composites
push(@$legary, ($$dnames[$i] . '.' . $colnames[$c])),
next
if ($$dnames[$i]);
push(@$legary, $colnames[$c]);
}
}
elsif ($#$dtypes > 1) {
#
# single range, composite
push(@legends, ($$dnames[$i] ? $$dnames[$i] : "PLOT$i"));
}
}
#
# establish icon list if any
#
my @icons = ();
my $iconlist = $$props{ICON};
if ($$props{ICON}) {
for ($k = 1, $j = 0; $k <= $#$data; $k++) {
push(@icons, $$iconlist[$j++]);
$j = 0 if ($j > $#$iconlist);
}
$img->setOptions( icons => \@icons );
}
if (($$dtypes[$i] eq 'BARCHART') ||
($$dtypes[$i] eq 'HISTOGRAM')) {
#
# first data array is domain names, the rest are
# datasets. If more than 1 dataset is supplied, then
# bars are grouped
#
$propstr .= ($$dtypes[$i] eq 'HISTOGRAM') ? 'histo ' : 'bar ';
if ($$props{Z_AXIS}) {
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints($$data[0], $$data[1], $$data[2],
$propstr . $colors[0]),
next;
}
#
# if single domain and multiple colors, then push all colors into
# the property string
$propstr.= ' float' unless $$props{ANCHORED};
if (($#$data == 1) && (! $$props{ICON})) {
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints($$data[0], $$data[1],
$propstr . ' ' . join(' ', @colors)),
next;
}
#
# if stacked, send all the data at the same time
#
if ($$props{STACK}) {
$propstr .= ' ' . ($$props{ICON} ? 'icon:' . join(' icon:', @icons) : join(' ', @colors));
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints(@$data, $propstr);
next;
}
for ($i=1; $i <= $#$data; $i++) {
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints($$data[0], $$data[$i],
$propstr . ($$props{ICON} ? 'icon:' . $icons[$i-1] : $colors[$i-1]));
}
next;
}
#
# establish shape list, and merge with icon list if needed
#
my @shapes = ();
$propstr .= ' candle ' . join(' ', @colors);
$propstr .= ' ' . $shapes[0]
if ($$props{SHOWPOINTS});
$propstr .= ' width:' . ($$props{LINEWIDTH} ? $$props{LINEWIDTH} : 2);
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints(@$data, $propstr);
next;
}
for (my $n = 0, $k = 1; $k <= $#$data; $k += 2, $n++) {
$propstr .= ' candle ' . $colors[$n];
$propstr .= ' ' . $shapes[$n]
if ($$props{SHOWPOINTS});
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints($$data[0], $$data[$k], $$data[$k+1], $propstr);
}
next;
}
if ($$dtypes[$i] eq 'BOXCHART') {
#
# each data array is a distinct domain to be plotted
#
for (my $n = 0, $k = 0; $k <= $#$data; $k++, $n++) {
$propstr .= ' box ' . $colors[$n];
$propstr .= ' ' . $shapes[$n]
if ($$props{SHOWPOINTS});
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints($$data[$k], $propstr);
}
next;
}
#
# line, point, or area graph
#
$img->setOptions( lineWidth => ($$props{LINEWIDTH} ? $$props{LINEWIDTH} : 1));
if (($$dtypes[$i] eq 'AREAGRAPH') && ($$props{STACK})) {
$propstr .= ' fill ' . join(' ', @colors) ;
$propstr .= ' ' . join(' ', @shapes)
if ($$props{SHOWPOINTS} || $$props{SHAPE});
$propstr .= ' float' unless $$props{ANCHORED};
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints(@$data, $propstr);
next;
}
for ($k = 1; $k <= $#$data; $k++) {
my $tprops = $propstr . ' ';
$tprops .= ($$dtypes[$i] eq 'POINTGRAPH') ?
'noline ' . $colors[$k-1] . ' ' . $shapes[$k-1] :
($$dtypes[$i] eq 'LINEGRAPH') ?
$colors[$k-1] :
'fill ' . $colors[$k-1] ;
$tprops .= ' ' . $shapes[$k-1]
if ($$props{SHOWPOINTS} || $$props{SHAPE});
$tprops .= ' width:' . ($$props{LINEWIDTH} ? $$props{LINEWIDTH} : 1);
$tprops .= ' float' unless $$props{ANCHORED};
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $img->setPoints($$data[0], $$data[$k], $tprops);
}
}
#
# if we have a legend, add it before plotting
$img->setOptions( legend => \@legends)
if ($#legends >= 0);
#
# all the image data loaded, now plot it
#
$sth->{chart_image} = $img->plot($dprops->[0]->{FORMAT});
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $sth->{chart_image};
$sth->{chart_imagemap} =
($sth->{chart_imagemap}) ? $img->getMap() : undef;
return $sth->DBI::set_err(-1, $img->{errmsg}, 'S1000')
unless $sth->{chart_image};
#
# update precision values
$precs = $sth->{PRECISION};
$$precs[0] = length($sth->{chart_image});
$$precs[1] = length($sth->{chart_imagemap}) if $sth->{chart_imagemap};
return 1;
}
sub convert_time {
my ($value, $type) = @_;
#
# use Perl funcs to compute seconds from date
return timegm(0, 0, 0, $3, $2 - 1, $1)
if (($type == SQL_DATE) &&
($value=~/^(\d+)[\-\.\/](\d+)[\-\.\/](\d+)$/));
return timegm(0, 0, 0, $3, $month{uc $2}, $1)
if (($type == SQL_DATE) &&
($value=~/^(\d+)[\-\.\/](\w+)[\-\.\/](\d+)$/));
return timegm($6, $5, $4, $3, $2 - 1, $1) + ($7 ? $7 : 0)
if (($type == SQL_TIMESTAMP) &&
($value=~/^(\d+)[\-\.\/](\d+)[\-\.\/](\d+)\s+(\d+):(\d+):(\d+)(\.\d+)?$/));
return timegm($6, $5, $4, $3, $month{uc $2}, $1) + ($7 ? $7 : 0)
if (($type == SQL_TIMESTAMP) &&
($value=~/^(\d+)[\-\.\/](\w+)[\-\.\/](\d+)\s+(\d+):(\d+):(\d+)(\.\d+)?$/));
return (($1 ? (($1 eq '-') ? -1 : 1) : 1) *
(($3 ? ($3 * 3600) : 0) + ($5 ? ($5 * 60) : 0) + $6 + ($7 ? $7 : 0)))
if ((($type == SQL_INTERVAL_HR2SEC) || ($type == SQL_TIME)) &&
($value=~/^([\-\+])?((\d+):)?((\d+):)?(\d+)(\.\d+)?$/));
return undef; # for completeness, shouldn't get here
}
sub test_predicate {
my ($rowmap, $pctype, $pc, $predop, $predval, $rownum) = @_;
for (my $i = 0; $i <= $#$pc; $i++) {
$$rowmap{$i} = -1, next
if ((($pctype == SQL_CHAR) || ($pctype == SQL_VARCHAR)) &&
(eval "\'$$pc[$i]\' $strpredops{$predop} \'$predval\'"));
$$rowmap{$i} = -1, next
if (($numtype{$pctype}) &&
(eval "$$pc[$i] $numpredops{$predop} $predval"));
if ($timetype{$pctype}) {
my ($col, $operand) = (convert_time($$pc[$i], $pctype), convert_time($predval, $pctype));
( run in 1.683 second using v1.01-cache-2.11-cpan-e1769b4cff6 )