Ready for 7.10.29 development.
This commit is contained in:
Colin Kuskie
commit
c806f99b7b
4236 changed files with 1217679 additions and 0 deletions
555
lib/WebGUI/Image/Color.pm
Normal file
555
lib/WebGUI/Image/Color.pm
Normal file
|
|
@ -0,0 +1,555 @@
|
|||
package WebGUI::Image::Color;
|
||||
|
||||
use strict;
|
||||
use Color::Calc;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Image::Color
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Package for managing WebGUI colors.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Colors actually consist of two colors: fill color and stroke color. Stroke color
|
||||
is the color for lines and the border of areas, while the fill color is the
|
||||
color that is used to fill that area. Fill color thus have no effect on lines.
|
||||
|
||||
Each fill and stroke color consists of a Red, Green, Blue and Alpha component.
|
||||
These values are given in hexadecimal notation. A concatenation of the Red,
|
||||
Greean and Blue values, prepended with a '#' sign is called a triplet. A similar
|
||||
combination that also includes the Alpha values at the end is called a quarted.
|
||||
|
||||
Alpha value are used to define the transparency of the color. The higher the
|
||||
value the more transparent the color is. If the alpha value = 00 the color is
|
||||
opaque, where the color is completely invisible for an alpha value of ff.
|
||||
|
||||
Colors are not saved to the database by default. If you want to do this you must
|
||||
do so manually using the save and/or update methods.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canDelete ( )
|
||||
|
||||
Returns true if this color can be deleted.
|
||||
|
||||
=cut
|
||||
|
||||
sub canDelete {
|
||||
my $self = shift;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 copy ( )
|
||||
|
||||
Returns a new WebGUI::Image::Color object being an exact copy of this color,
|
||||
except for the persistency. This means that the new copy will not be stored in
|
||||
the database. To accomplish that use the save method on the copy.
|
||||
|
||||
=cut
|
||||
|
||||
sub copy {
|
||||
my $self = shift;
|
||||
|
||||
return WebGUI::Image::Color->new($self->session, 'new', {%{$self->{_properties}}});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 darken ( )
|
||||
|
||||
Returns a new WebGUI::Image::Color object with the same properties but the
|
||||
colors darkened. This object will not be saved to the database automatically.
|
||||
Use the save method on it if you want to do so.
|
||||
|
||||
=cut
|
||||
|
||||
sub darken {
|
||||
my $self = shift;
|
||||
|
||||
my $newColor = $self->copy;
|
||||
|
||||
my $c = Color::Calc->new(OutputFormat => 'hex');
|
||||
|
||||
$newColor->setFillTriplet('#'.$c->dark($self->getFillTriplet));
|
||||
$newColor->setStrokeTriplet('#'.$c->dark($self->getStrokeTriplet));
|
||||
|
||||
return $newColor;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete ( )
|
||||
|
||||
Deletes the color from the database. It will only delete if canDelete returns
|
||||
true.
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my $self = shift;
|
||||
if ($self->canDelete) {
|
||||
$self->session->db->write('delete from imageColor where colorId=?', [
|
||||
$self->getId,
|
||||
]);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFillColor ( )
|
||||
|
||||
Returns the the quartet of th fill color. The quartet consists of R, G, B and
|
||||
Alpha values respectively in HTML format: '#rrggbbaa'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getFillColor {
|
||||
my $self = shift;
|
||||
|
||||
return $self->getFillTriplet.$self->getFillAlpha;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFillTriplet ( )
|
||||
|
||||
Returns the RGB triplet of the fill color in HTML format: '#rrggbb'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getFillTriplet {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{fillTriplet};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFillAlpha ( )
|
||||
|
||||
Returns the hex value of the Alpha channel in this color.
|
||||
|
||||
=cut
|
||||
|
||||
sub getFillAlpha {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{fillAlpha};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getId ( )
|
||||
|
||||
Returns the GUID of this color.
|
||||
|
||||
=cut
|
||||
|
||||
sub getId {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{colorId};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getName ( )
|
||||
|
||||
Returns the name assigned to this color.
|
||||
|
||||
=cut
|
||||
|
||||
sub getName {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{name};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getStrokeColor ( )
|
||||
|
||||
Returns the the quartet of the stroke color. The quartet consists of R, G, B and
|
||||
Alpha values respectively in HTML format: '#rrggbbaa'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getStrokeColor {
|
||||
my $self = shift;
|
||||
|
||||
return $self->getStrokeTriplet.$self->getStrokeAlpha;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getStrokeTriplet ( )
|
||||
|
||||
Returns the RGB triplet of the stroke color in HTML format: '#rrggbb'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getStrokeTriplet {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{strokeTriplet};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getStrokeAlpha ( )
|
||||
|
||||
Returns the hex value of the Alpha channel in the stroke color.
|
||||
|
||||
=cut
|
||||
|
||||
sub getStrokeAlpha {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{strokeAlpha};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session, colorId, [ properties ] )
|
||||
|
||||
Constructor for this class.
|
||||
|
||||
=head3 session
|
||||
|
||||
A WebGUI::Session object.
|
||||
|
||||
=head3 colorId
|
||||
|
||||
The id of the color you want to instanciate. If you're creating a new color
|
||||
please use 'new' as id.
|
||||
|
||||
=head3 properties
|
||||
|
||||
A hashref containing configuration options to set this object to. All are also
|
||||
available through methods.
|
||||
|
||||
=head4 name
|
||||
|
||||
The color name.
|
||||
|
||||
=head4 fillTriplet
|
||||
|
||||
The RGB triplet for the fill color. See setFillTriplet.
|
||||
|
||||
=head4 fillAlpha
|
||||
|
||||
The alpha value for the fill color. See setFillAlpha.
|
||||
|
||||
=head4 strokeTriplet
|
||||
|
||||
The RGB triplet for the stroke color. See setStrokeTriplet.
|
||||
|
||||
=head4 strokeAlpha
|
||||
|
||||
The alpha value for the stroke color. See setStrokeAlpha.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $colorId = shift;
|
||||
my $properties = shift;
|
||||
|
||||
if ($colorId eq 'new') {
|
||||
unless (defined $properties) {
|
||||
$properties = {
|
||||
name => 'untitled',
|
||||
fillTriplet => '#000000',
|
||||
fillAlpha => '00',
|
||||
strokeTriplet => '#000000',
|
||||
strokeAlpha => '00',
|
||||
};
|
||||
}
|
||||
$properties->{colorId} = 'new';
|
||||
} elsif (!defined $properties) {
|
||||
$properties = $session->db->quickHashRef('select * from imageColor where colorId=?', [$colorId]);
|
||||
}
|
||||
|
||||
bless {_properties => $properties, _session => $session}, $class;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 newByPalette ( session, paletteId )
|
||||
|
||||
Returns an arrayref containg instanciated WebGUI::Image::Color objects for each
|
||||
color in the sepcified palette.
|
||||
|
||||
=head3 session
|
||||
|
||||
A WebGUI::Session object.
|
||||
|
||||
=head3 paletteId
|
||||
|
||||
The id of the palette that is to be loaded.
|
||||
|
||||
=cut
|
||||
|
||||
sub newByPalette {
|
||||
my ($sth, $row, @colors);
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $paletteId = shift;
|
||||
|
||||
$sth = $session->db->read('select imageColor.* from imageColor, imagePaletteColors where '.
|
||||
' imageColor.colorId=imagePaletteColors.colorId and paletteId=?', [
|
||||
$paletteId
|
||||
]);
|
||||
|
||||
while ($row = $sth->hashRef) {
|
||||
push(@colors, WebGUI::Image::Color->new($session, $row->{colorId}, $row));
|
||||
}
|
||||
|
||||
return \@colors;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns the WebGUI::Session object;
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setFillColor ( quartet )
|
||||
|
||||
Sets the the fill color to the specified quartet.
|
||||
|
||||
=head3 quartet
|
||||
|
||||
The quartet consists of R, G, B and Alpha values respectively in HTML format: '#rrggbbaa'.
|
||||
|
||||
=cut
|
||||
|
||||
sub setFillColor {
|
||||
my $self = shift;
|
||||
my $color = shift;
|
||||
|
||||
if ($color =~ m/^(#[\da-f]{6})([\da-f]{2})?$/i) {
|
||||
$self->setFillTriplet($1);
|
||||
$self->setFillAlpha($2 || '00');
|
||||
} else {
|
||||
$self->session->errorHandler->fatal("Invalid fill color: ($color)");
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setFillTriplet ( triplet )
|
||||
|
||||
Sets the RGB triplet of the fill color.
|
||||
|
||||
=head3 triplet
|
||||
|
||||
The RGB triplet in HTML format: '#rrggbb'.
|
||||
|
||||
=cut
|
||||
|
||||
sub setFillTriplet {
|
||||
my $self = shift;
|
||||
my $triplet = shift;
|
||||
|
||||
if ($triplet =~ m/^#[\da-f]{6}$/i) {
|
||||
$self->{_properties}->{fillTriplet} = $triplet;
|
||||
$self->update;
|
||||
} else {
|
||||
$self->session->errorHandler->fatal("Invalid fill triplet: ($triplet)");
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setFillAlpha ( alpha )
|
||||
|
||||
Sets the alpha channel for the fill color.
|
||||
|
||||
=head3 alpha
|
||||
|
||||
The alpha value in hexadecimal notation: 'ff';
|
||||
|
||||
=cut
|
||||
|
||||
sub setFillAlpha {
|
||||
my $self = shift;
|
||||
my $alpha = shift;
|
||||
|
||||
if ($alpha =~ m/^[\da-f]{2}$/i) {
|
||||
$self->{_properties}->{fillAlpha} = $alpha;
|
||||
$self->update;
|
||||
} else {
|
||||
$self->session->errorHandler->fatal("Invalid fill alpha: ($alpha)");
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setName ( name )
|
||||
|
||||
Sets the name of this color.
|
||||
|
||||
=head3 name
|
||||
|
||||
A scalar containing the name of this color.
|
||||
|
||||
=cut
|
||||
|
||||
sub setName {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
|
||||
$self->{_properties}->{name} = $name;
|
||||
$self->update;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setStrokeColor ( quartet )
|
||||
|
||||
Sets the the stroke color to the specified quartet.
|
||||
|
||||
=head3 quartet
|
||||
|
||||
The quartet consists of R, G, B and Alpha values respectively in HTML format: '#rrggbbaa'.
|
||||
|
||||
=cut
|
||||
|
||||
sub setStrokeColor {
|
||||
my $self = shift;
|
||||
my $color = shift;
|
||||
|
||||
if ($color =~ m/^(#[\da-f]{6})([\da-f]{2})?$/i) {
|
||||
$self->setStrokeTriplet($1);
|
||||
$self->setStrokeAlpha($2 || '00');
|
||||
} else {
|
||||
$self->session->errorHandler->fatal("Invalid stroke color: ($color)");
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setStrokeTriplet ( triplet )
|
||||
|
||||
Sets the RGB triplet of the stroke color.
|
||||
|
||||
=head3 triplet
|
||||
|
||||
The RGB triplet in HTML format: '#rrggbb'.
|
||||
|
||||
=cut
|
||||
|
||||
sub setStrokeTriplet {
|
||||
my $self = shift;
|
||||
my $triplet = shift;
|
||||
|
||||
if ($triplet =~ m/^#[\da-f]{6}$/i) {
|
||||
$self->{_properties}->{strokeTriplet} = $triplet;
|
||||
$self->update;
|
||||
} else {
|
||||
$self->session->errorHandler->fatal("Invalid stroke triplet: ($triplet)");
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setStrokeAlpha ( alpha )
|
||||
|
||||
Sets the alpha channel for the stroke color.
|
||||
|
||||
=head3 alpha
|
||||
|
||||
The alpha value in hexadecimal notation: 'ff';
|
||||
|
||||
=cut
|
||||
|
||||
sub setStrokeAlpha {
|
||||
my $self = shift;
|
||||
my $alpha = shift;
|
||||
|
||||
if ($alpha =~ m/^[\da-f]{2}$/i) {
|
||||
$self->{_properties}->{strokeAlpha} = $alpha;
|
||||
$self->update;
|
||||
} else {
|
||||
$self->session->errorHandler->fatal("Invalid stroke alpha: ($alpha)");
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 update ( )
|
||||
|
||||
Will update the database to the current state of the object. If your object has
|
||||
not yet been saved to the database, you must first use the save method, which
|
||||
has the same functionality.
|
||||
|
||||
=cut
|
||||
|
||||
sub update {
|
||||
my $self = shift;
|
||||
|
||||
$self->session->db->write("update imageColor set name=?, fillTriplet=?, fillAlpha=?, strokeTriplet=?, strokeAlpha=? where colorId=?", [
|
||||
$self->getName,
|
||||
$self->getFillTriplet,
|
||||
$self->getFillAlpha,
|
||||
$self->getStrokeTriplet,
|
||||
$self->getStrokeAlpha,
|
||||
$self->getId
|
||||
]);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 save ( )
|
||||
|
||||
Will save the state of the object to the database if the color is not yet in the
|
||||
database. If it already is in the database this method will do exactly the same
|
||||
as update.
|
||||
|
||||
=cut
|
||||
|
||||
sub save {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->getId eq 'new') {
|
||||
$self->{_properties}->{colorId} = $self->session->id->generate;
|
||||
$self->session->db->write("insert into imageColor (colorId, name, fillTriplet, fillAlpha, strokeTriplet, strokeAlpha) values (?,?,?,?,?,?)", [
|
||||
$self->getId,
|
||||
$self->getName || 'untitled',
|
||||
$self->getFillTriplet || '#000000',
|
||||
$self->getFillAlpha || '00',
|
||||
$self->getStrokeTriplet || '#000000',
|
||||
$self->getStrokeAlpha || '00',
|
||||
]);
|
||||
}
|
||||
|
||||
$self->update;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
216
lib/WebGUI/Image/Font.pm
Normal file
216
lib/WebGUI/Image/Font.pm
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
package WebGUI::Image::Font;
|
||||
|
||||
use strict;
|
||||
use WebGUI::Storage;
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canDelete
|
||||
|
||||
=cut
|
||||
|
||||
sub canDelete {
|
||||
my $self = shift;
|
||||
|
||||
return 0 if ($self->getId =~ m/^default/);
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->canDelete) {
|
||||
my $storage = WebGUI::Storage->get($self->session, $self->getStorageId);
|
||||
$storage->deleteFile($self->getFilename);
|
||||
|
||||
$self->session->db->write('delete from imageFont where fontId=?', [
|
||||
$self->getId,
|
||||
]);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getId
|
||||
|
||||
=cut
|
||||
|
||||
sub getId {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{fontId};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFontList
|
||||
|
||||
=cut
|
||||
|
||||
sub getFontList {
|
||||
my $self = shift;
|
||||
my $session = shift || $self->session;
|
||||
|
||||
return $session->db->buildHashRef('select fontId, name from imageFont');
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFile
|
||||
|
||||
=cut
|
||||
|
||||
sub getFile {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->getStorageId) {
|
||||
return WebGUI::Storage->get($self->session, $self->getStorageId)->getPath($self->getFilename);
|
||||
} else {
|
||||
return $self->session->config->getWebguiRoot."/lib/default.ttf"
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFilename
|
||||
|
||||
=cut
|
||||
|
||||
sub getFilename {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{filename};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getName
|
||||
|
||||
=cut
|
||||
|
||||
sub getName {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{name};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getStorageId
|
||||
|
||||
=cut
|
||||
|
||||
sub getStorageId {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{storageId};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $fontId = shift;
|
||||
my $properties = {};
|
||||
|
||||
if ($fontId eq 'new') {
|
||||
$fontId = $session->id->generate;
|
||||
|
||||
$session->db->write('insert into imageFont (fontId) values (?)', [
|
||||
$fontId,
|
||||
]);
|
||||
$properties->{fontId} = $fontId;
|
||||
} else {
|
||||
$properties = $session->db->quickHashRef('select * from imageFont where fontId=?', [
|
||||
$fontId,
|
||||
]);
|
||||
|
||||
unless ($properties->{fontId}) {
|
||||
$properties = $session->db->quickHashRef('select * from imageFont where fontId=?', [
|
||||
'defaultFont',
|
||||
]);
|
||||
}
|
||||
}
|
||||
|
||||
bless {_properties => $properties, _session => $session}, $class;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setFilename
|
||||
|
||||
=cut
|
||||
|
||||
sub setFilename {
|
||||
my $self = shift;
|
||||
my $filename = shift;
|
||||
|
||||
$self->session->db->write('update imageFont set filename=? where fontId=?', [
|
||||
$filename,
|
||||
$self->getId,
|
||||
]);
|
||||
|
||||
$self->{_properties}->{filename} = $filename;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setName
|
||||
|
||||
=cut
|
||||
|
||||
sub setName {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
|
||||
$self->session->db->write('update imageFont set name=? where fontId=?', [
|
||||
$name,
|
||||
$self->getId,
|
||||
]);
|
||||
|
||||
$self->{_properties}->{name} = $name;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setStorageId
|
||||
|
||||
=cut
|
||||
|
||||
sub setStorageId {
|
||||
my $self = shift;
|
||||
my $storageId = shift;
|
||||
|
||||
$self->session->db->write('update imageFont set storageId=? where fontId=?', [
|
||||
$storageId,
|
||||
$self->getId,
|
||||
]);
|
||||
|
||||
$self->{_properties}->{storageId} = $storageId;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
793
lib/WebGUI/Image/Graph.pm
Normal file
793
lib/WebGUI/Image/Graph.pm
Normal file
|
|
@ -0,0 +1,793 @@
|
|||
package WebGUI::Image::Graph;
|
||||
|
||||
use strict;
|
||||
use WebGUI::Image;
|
||||
use WebGUI::Image::Palette;
|
||||
use WebGUI::Image::Font;
|
||||
use List::Util;
|
||||
use WebGUI::Utility;
|
||||
use WebGUI::Pluggable;
|
||||
|
||||
our @ISA = qw(WebGUI::Image);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Image::Graph
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Base class for graphs.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This package provides the basic needs for creating graphs.
|
||||
|
||||
Among others this package provides the base methods for configuration forms,
|
||||
dataset addition, loading plugins, and setting general parameters like
|
||||
backgraound color.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 addDataset ( dataset )
|
||||
|
||||
Adds a dataset to the graph. Please not that not all graph types can handle
|
||||
multiple datasets and will therefore ignore any dataset but the first.
|
||||
|
||||
=head3 dataset
|
||||
|
||||
An arrayref containg the values of the data. The dat must be numeric.
|
||||
|
||||
=cut
|
||||
|
||||
sub addDataset {
|
||||
my $self = shift;
|
||||
my $dataset = shift;
|
||||
|
||||
push(@{$self->{_datasets}}, $dataset);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 configurationForm ( )
|
||||
|
||||
Returns a hashref containing the form where the properties of your graph type
|
||||
can be set. Your pluging should extend this method by append the form to the
|
||||
hashref returned by the super method and returning the reference.
|
||||
|
||||
The key for this entry must be unique, so use the namespace of your plugin
|
||||
without the WebGUI::Image part; the :: converted to and underscore and
|
||||
everything in lowercase.
|
||||
|
||||
Check some of the plugins that come with WebGUI for examples.
|
||||
|
||||
=cut
|
||||
|
||||
sub configurationForm {
|
||||
my $self = shift;
|
||||
|
||||
my $i18n = WebGUI::International->new($self->session, 'Image_Graph');
|
||||
|
||||
my $f = WebGUI::HTMLForm->new($self->session);
|
||||
$f->trClass('Graph');
|
||||
$f->integer(
|
||||
-name => 'graph_imageWidth',
|
||||
-value => $self->getImageWidth,
|
||||
-label => $i18n->get('image width'),
|
||||
-hoverHelp => $i18n->get('image width description'),
|
||||
);
|
||||
$f->integer(
|
||||
-name => 'graph_imageHeight',
|
||||
-value => $self->getImageHeight,
|
||||
-label => $i18n->get('image height'),
|
||||
-hoverHelp => $i18n->get('image height description'),
|
||||
);
|
||||
$f->color(
|
||||
-name => 'graph_backgroundColor',
|
||||
-value => $self->getBackgroundColor,
|
||||
-label => $i18n->get('background color'),
|
||||
-hoverHelp => $i18n->get('background color description'),
|
||||
);
|
||||
$f->selectBox(
|
||||
-name => 'graph_paletteId',
|
||||
-label => $i18n->get('palette'),
|
||||
-hoverHelp => $i18n->get('palette description'),
|
||||
-value => [ $self->getPalette->getId ],
|
||||
-options=> $self->getPalette->getPaletteList,
|
||||
);
|
||||
$f->float(
|
||||
-name => 'graph_labelOffset',
|
||||
-value => $self->getLabelOffset,
|
||||
-label => $i18n->get('label offset'),
|
||||
-hoverHelp => $i18n->get('label offset description'),
|
||||
);
|
||||
$f->selectBox(
|
||||
-name => 'graph_labelFontId',
|
||||
-value => [ $self->getLabelFont->getId ],
|
||||
-label => $i18n->get('label font'),
|
||||
-hoverHelp => $i18n->get('label font description'),
|
||||
-options=> WebGUI::Image::Font->getFontList($self->session),
|
||||
);
|
||||
$f->color(
|
||||
-name => 'graph_labelColor',
|
||||
-value => $self->getLabelColor,
|
||||
-label => $i18n->get('label color'),
|
||||
-hoverHelp => $i18n->get('label color description'),
|
||||
);
|
||||
$f->integer(
|
||||
-name => 'graph_labelFontSize',
|
||||
-value => $self->getLabelFontSize,
|
||||
-label => $i18n->get('label fontsize'),
|
||||
-hoverHelp => $i18n->get('label fontsize description'),
|
||||
);
|
||||
|
||||
return {'graph' => $f->printRowsOnly};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawLabel ( label, [ properties ] )
|
||||
|
||||
Draws a label with your preferred properties. Defaults the font, font size and
|
||||
color which you can override.
|
||||
|
||||
=head3 label
|
||||
|
||||
The text of the label you want to print.
|
||||
|
||||
=head3 properties
|
||||
|
||||
A hash containing imagemagick Annotate properties.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawLabel {
|
||||
my $self = shift;
|
||||
my $label = shift;
|
||||
my %properties = @_;
|
||||
|
||||
$self->text(
|
||||
text => $label,
|
||||
font => $self->getLabelFont->getFile,
|
||||
fill => $self->getLabelColor,
|
||||
style => 'Normal',
|
||||
pointsize => $self->getLabelFontSize,
|
||||
%properties,
|
||||
);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 formNamespace ( )
|
||||
|
||||
Returns the namespace used in the configuration form. You must extend this
|
||||
method by concatenating an underscore and the last part of your namespace to the
|
||||
output of the SUPER method.
|
||||
|
||||
For examples please see the implementation in the plugins that come with WebGUI.
|
||||
|
||||
=cut
|
||||
|
||||
sub formNamespace {
|
||||
return "Graph";
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getConfiguration ( )
|
||||
|
||||
Returns the configuration hashref of the plugin. You must extend this method by
|
||||
adding your configuration keys to the hashref returned by the SUPER method. To
|
||||
avoid conflicts prepend your configuration keys with the namespace of your
|
||||
plugin, encoded as follows: take the part of the namespace without
|
||||
WebGUI::Image, convert it to lowercase and substitute the :: with a single
|
||||
underscore.
|
||||
|
||||
Check out the plugins that are shipped with WebGUI for examples.
|
||||
|
||||
=cut
|
||||
|
||||
sub getConfiguration {
|
||||
my $self = shift;
|
||||
|
||||
return {
|
||||
graph_formNamespace => $self->formNamespace,
|
||||
graph_paletteId => $self->getPalette->getId,
|
||||
graph_labelOffset => $self->getLabelOffset,
|
||||
graph_labelFontSize => $self->getLabelFontSize,
|
||||
graph_labelFontId => $self->getLabelFont->getId,
|
||||
graph_labelColor => $self->getLabelColor,
|
||||
graph_imageWidth => $self->getImageWidth,
|
||||
graph_imageHeight => $self->getImageHeight,
|
||||
graph_backgroundColor => $self->getBackgroundColor,
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getGraphingTab ( session, [ config ] )
|
||||
|
||||
Returns the contents of the graphing tab you can add to your asset.
|
||||
|
||||
This is a class method, and therefore you must pass the WebGUI session object.
|
||||
|
||||
=head3 session
|
||||
|
||||
An instanciated WebGUI session object.
|
||||
|
||||
=head3 config
|
||||
|
||||
Optionally you can pass a configuration hash to populate the form
|
||||
|
||||
=cut
|
||||
|
||||
sub getGraphingTab {
|
||||
my (%configForms, $output);
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $config = shift;
|
||||
|
||||
my (@graphingPlugins, %graphingPlugins, @failedGraphingPlugins);
|
||||
|
||||
my $i18n = WebGUI::International->new($session, 'Image_Graph');
|
||||
|
||||
my $f = WebGUI::HTMLForm->new($session);
|
||||
|
||||
unless ($session->config->get("graphingPlugins")) {
|
||||
$f->readOnly(
|
||||
-value => $i18n->get('no graphing plugins in config'),
|
||||
);
|
||||
|
||||
return $f->printRowsOnly;
|
||||
}
|
||||
|
||||
foreach (@{$session->config->get("graphingPlugins")}) {
|
||||
my $plugin = WebGUI::Image::Graph->load($session, $_);
|
||||
if ($plugin) {
|
||||
push(@graphingPlugins, $plugin);
|
||||
$plugin->setConfiguration($config);
|
||||
$graphingPlugins{$plugin->formNamespace} = $_;
|
||||
} else {
|
||||
push(@failedGraphingPlugins, $_);
|
||||
}
|
||||
}
|
||||
|
||||
my $ns = $config->{graph_formNamespace};
|
||||
# payment plugin
|
||||
if (%graphingPlugins) {
|
||||
$session->style->setRawHeadTags(<<EOS
|
||||
<script type="text/javascript">
|
||||
function inNamespace (clas, namespace) {
|
||||
var namespaceParts = namespace.split('_');
|
||||
var s = '';
|
||||
|
||||
for (var i = 0; i < namespaceParts.length; i++) {
|
||||
if (i > 0) {
|
||||
s = s + '_';
|
||||
}
|
||||
s = s + namespaceParts[i];
|
||||
|
||||
if (s == clas) {
|
||||
return true;
|
||||
}
|
||||
}
|
||||
|
||||
return false;
|
||||
}
|
||||
|
||||
function getContainerTag (elem, tagname) {
|
||||
var parent = elem.parentNode;
|
||||
|
||||
while (parent.tagName != tagname) {
|
||||
parent = parent.parentNode;
|
||||
}
|
||||
|
||||
return parent;
|
||||
}
|
||||
|
||||
function switchGraphingFormElements (elem, namespace) {
|
||||
var rowElements = getContainerTag(elem, 'TABLE').getElementsByTagName('TR');
|
||||
|
||||
for (var ix = 0; ix < rowElements.length; ix++) {
|
||||
if (inNamespace(rowElements[ix].className, namespace)) {
|
||||
rowElements[ix].style.display = '';
|
||||
} else {
|
||||
if (rowElements[ix].className.match(/^Graph_/)) {
|
||||
rowElements[ix].style.display = 'none';
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
</script>
|
||||
EOS
|
||||
);
|
||||
|
||||
$f->selectBox(
|
||||
-name => 'graphingPlugin',
|
||||
-options => \%graphingPlugins,
|
||||
-label => $i18n->get('graph type'),
|
||||
-hoverHelp => $i18n->get('graph type description'),
|
||||
-id => 'graphTypeSelector',
|
||||
-value => [ $config->{graph_formNamespace} ],
|
||||
-extras => 'onchange="switchGraphingFormElements(this, this.value)"'
|
||||
);
|
||||
|
||||
foreach my $currentPlugin (@graphingPlugins) {
|
||||
%configForms = (%configForms, %{$currentPlugin->configurationForm});
|
||||
}
|
||||
} else {
|
||||
$f->raw('<tr><td colspan="2" align="left">'.$i18n->get('no graphing plugins').'</td></tr>');
|
||||
}
|
||||
|
||||
foreach (sort keys %configForms) {
|
||||
$f->raw($configForms{$_});
|
||||
}
|
||||
|
||||
$f->raw('<script type="text/javascript">'.
|
||||
"switchGraphingFormElements(document.getElementById('graphTypeSelector'), '$ns');".
|
||||
'</script>'
|
||||
);
|
||||
|
||||
return $f->printRowsOnly;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getDataset ( [ index ] )
|
||||
|
||||
Returns the dataset indicated by index.
|
||||
|
||||
=head3 index
|
||||
|
||||
The index of the array containing the datasets. The first dataset is indicated
|
||||
by index 0. If ommitted this method returns an arrayref of arrayrefs containing
|
||||
all datasets.
|
||||
|
||||
=cut
|
||||
|
||||
sub getDataset {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
return $self->{_datasets} unless (defined $index);
|
||||
|
||||
die "Illegal dataset" if ($index >= scalar(@{$self->{_datasets}}));
|
||||
|
||||
return $self->{_datasets}->[$index];
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLabel ( [ index ] )
|
||||
|
||||
Returns the index'th label or an arrayref containing all labels.
|
||||
|
||||
=head3 index
|
||||
|
||||
The index of label to return. Numbering starts at 0. If omitted an arrayref
|
||||
containing all labels is returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLabel {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
return $self->{_labels}->{data} || [] unless (defined $index);
|
||||
return $self->{_labels}->{data}->[$index];
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLabelColor
|
||||
|
||||
Returns the triplet of the label color. Defaults to '#333333'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLabelColor {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_labels}->{labelColor} || '#333333';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLabelDimensions ( text, [ properties ] )
|
||||
|
||||
Returns a hashref containg the width and height in pixels of the passed text.
|
||||
Width and height are referenced by the keys 'width' and 'height' respectively.
|
||||
|
||||
=head3 text
|
||||
|
||||
The text you want to know the dimensions of.
|
||||
|
||||
=head3 properties
|
||||
|
||||
Optionally you can pass a hashref containing imagemagick's Annotate properties.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLabelDimensions {
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
my $properties = shift || {};
|
||||
|
||||
my ($x_ppem, $y_ppem, $ascender, $descender, $width, $height, $max_advance) = $self->image->QueryFontMetrics(
|
||||
font => $self->getLabelFont->getFile,
|
||||
# stroke => $self->getLabelColor,
|
||||
fill => $self->getLabelColor,
|
||||
style => 'Normal',
|
||||
pointsize => $self->getLabelFontSize,
|
||||
%$properties,
|
||||
text => $text,
|
||||
);
|
||||
|
||||
return {width => $width, height => $height};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLabelFont ( )
|
||||
|
||||
Returns the WebGUI::Image::Font object this image is set to. Defaults to the
|
||||
default font.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLabelFont {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_labels}->{labelFont} || WebGUI::Image::Font->new($self->session);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLabelFontSize ( )
|
||||
|
||||
Returns the font size of the labels. Defaults to 20.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLabelFontSize {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_labels}->{labelFontSize} || 20;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getLabelOffset ( )
|
||||
|
||||
Returns the label offset. This is the distance between the label and the axis.
|
||||
Defaults to 10 pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub getLabelOffset {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_labels}->{labelOffset} || 10;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getMaxValueFromDataset ( )
|
||||
|
||||
Returns the highest value of all added datasets.
|
||||
|
||||
=cut
|
||||
|
||||
sub getMaxValueFromDataset {
|
||||
my $self = shift;
|
||||
|
||||
my ($sum, $maxSum);
|
||||
|
||||
if ($self->getDrawMode eq 'stacked') {
|
||||
my $maxElements = List::Util::max(map {scalar @$_} @{$self->{_datasets}});
|
||||
my $numberOfDatasets = scalar @{$self->{_datasets}};
|
||||
|
||||
for my $currentElement (0 .. $maxElements-1) {
|
||||
$sum = 0;
|
||||
for my $currentDataset (0 .. $numberOfDatasets - 1) {
|
||||
$sum += $self->{_datasets}->[$currentDataset]->[$currentElement];
|
||||
}
|
||||
$maxSum = $sum if ($sum > $maxSum);
|
||||
}
|
||||
} else {
|
||||
$maxSum = List::Util::max(map {(@$_)} @{$self->{_datasets}});
|
||||
}
|
||||
|
||||
return $maxSum;
|
||||
|
||||
return List::Util::max(@{$self->{_dataset}});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getPluginList ( )
|
||||
|
||||
Returns an arrayref containing the namespaces of the enabled graphing plugins.
|
||||
|
||||
=cut
|
||||
|
||||
sub getPluginList {
|
||||
my $self = shift;
|
||||
my $session = shift || $self->session;
|
||||
|
||||
return $session->config->get("graphingPlugins");
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 load ( session, namespace )
|
||||
|
||||
Instanciates an WebGUI::Graph object with the given namespace.
|
||||
|
||||
=head3 session
|
||||
|
||||
A WebGUI::Session object.
|
||||
|
||||
=head3 namespace
|
||||
|
||||
The full namespace of the plugin you want to load.
|
||||
|
||||
=cut
|
||||
|
||||
sub load {
|
||||
my $self = shift;
|
||||
my $session = shift;
|
||||
my $namespace = shift;
|
||||
|
||||
my $plugin = eval {
|
||||
WebGUI::Pluggable::instanciate($namespace, 'new', [$session, ]);
|
||||
};
|
||||
return $plugin;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 loadByConfiguration ( session, configuration )
|
||||
|
||||
Loads a plugin defined by a configuration hash.
|
||||
|
||||
=head3 session
|
||||
|
||||
A WebGUI::Session object.
|
||||
|
||||
=head3 configuration
|
||||
|
||||
A configuration hashref.
|
||||
|
||||
=cut
|
||||
|
||||
sub loadByConfiguration {
|
||||
my $self = shift;
|
||||
my $session = shift;
|
||||
my $config = shift;
|
||||
|
||||
my $namespace = "WebGUI::Image::".$config->{graph_formNamespace};
|
||||
$namespace =~ s/_/::/g;
|
||||
|
||||
$session->errorHandler->fatal("wrong namespace: [$namespace]") unless ($config->{graph_formNamespace} =~ /^[\w\d_]+$/);
|
||||
|
||||
my $plugin = $self->load($session, $namespace);
|
||||
$plugin->setConfiguration($config);
|
||||
|
||||
return $plugin;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 processConfigurationForm ( session )
|
||||
|
||||
Processes the configuration form that is submitted and returns the correct
|
||||
instanciated graphing plugin.
|
||||
|
||||
=head3 session
|
||||
|
||||
The WebGUI session object.
|
||||
|
||||
=cut
|
||||
|
||||
sub processConfigurationForm {
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
|
||||
return undef unless ($class->getPluginList($session));
|
||||
|
||||
my $namespace = "WebGUI::Image::".$session->form->process('graphingPlugin');
|
||||
$namespace =~ s/_/::/g;
|
||||
|
||||
return undef unless (isIn($namespace, @{$class->getPluginList($session)}));
|
||||
|
||||
my $graph = $class->load($session, $namespace);
|
||||
|
||||
$graph->setConfiguration($session->form->paramsHashRef);
|
||||
|
||||
return $graph;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setConfiguration ( config )
|
||||
|
||||
Configures the pluging according to the configuration hashref that is passed.
|
||||
You must extend this method by calling the SUPER method with the configuration
|
||||
hashref and processing your part of the configuration options.
|
||||
|
||||
=head3 config
|
||||
|
||||
The configuration hashref.
|
||||
|
||||
=cut
|
||||
|
||||
sub setConfiguration {
|
||||
my $self = shift;
|
||||
my $config = shift;
|
||||
|
||||
$self->setPalette(WebGUI::Image::Palette->new($self->session, $config->{graph_paletteId}));
|
||||
$self->setLabelOffset($config->{graph_labelOffset});
|
||||
$self->setLabelFontSize($config->{graph_labelFontSize});
|
||||
$self->setLabelFont(WebGUI::Image::Font->new($self->session, $config->{graph_labelFontId}));
|
||||
$self->setLabelColor($config->{graph_labelColor});
|
||||
$self->setImageWidth($config->{graph_imageWidth});
|
||||
$self->setImageHeight($config->{graph_imageHeight});
|
||||
$self->setBackgroundColor($config->{graph_backgroundColor});
|
||||
|
||||
};
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setLabelColor ( color )
|
||||
|
||||
Sets the color triplet of the labels.
|
||||
|
||||
=head3 color
|
||||
|
||||
The triplet defining the color. The triplet should be in the form of '#ffffff'.
|
||||
|
||||
=cut
|
||||
|
||||
sub setLabelColor {
|
||||
my $self = shift;
|
||||
my $color = shift;
|
||||
|
||||
$self->{_labels}->{labelColor} = $color;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setLabelFont ( font )
|
||||
|
||||
Set the label font.
|
||||
|
||||
=head3 font
|
||||
|
||||
A WebGUI::Image::Font object.
|
||||
|
||||
=cut
|
||||
|
||||
sub setLabelFont {
|
||||
my $self = shift;
|
||||
my $font = shift;
|
||||
|
||||
$self->{_labels}->{labelFont} = $font;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setLabelFontSize ( size )
|
||||
|
||||
Sets the font size of the labels.
|
||||
|
||||
=head3 size
|
||||
|
||||
The desired font size.
|
||||
|
||||
=cut
|
||||
|
||||
sub setLabelFontSize {
|
||||
my $self = shift;
|
||||
my $size = shift;
|
||||
|
||||
$self->{_labels}->{labelFontSize} = $size;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setLabelOffset ( offset )
|
||||
|
||||
Sets the label offset. This is the distance in pixels between the labels and the
|
||||
axis.
|
||||
|
||||
=head3 offset
|
||||
|
||||
The label offset.
|
||||
|
||||
=cut
|
||||
|
||||
sub setLabelOffset {
|
||||
my $self = shift;
|
||||
my $offset = shift;
|
||||
|
||||
$self->{_labels}->{labelOffset} = $offset;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setLabels ( labels )
|
||||
|
||||
Sets the labels for the datasets.
|
||||
|
||||
=head3 labels
|
||||
|
||||
An arrayref containig the labels.
|
||||
|
||||
=cut
|
||||
|
||||
sub setLabels {
|
||||
my $self = shift;
|
||||
my $labels = shift || [];
|
||||
|
||||
$self->{_labels}->{data} = $labels;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 wrapLabelToWidth ( text, maxWidth, [ properties ] )
|
||||
|
||||
Wraps a text string onto multiple lines having a width of maxWidth.
|
||||
|
||||
=head3 text
|
||||
|
||||
The text you want to wrap.
|
||||
|
||||
=head3 maxWidth
|
||||
|
||||
The width the string should have after wrapping/
|
||||
|
||||
=head3 properties
|
||||
|
||||
An optional hashref containing imagemagick's Annotate properties.
|
||||
|
||||
=cut
|
||||
|
||||
sub wrapLabelToWidth {
|
||||
my (@words, $part, @lines);
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
my $maxWidth = shift;
|
||||
my $properties = shift;
|
||||
|
||||
@words = split(/ +/, $text);
|
||||
|
||||
foreach (@words) {
|
||||
if ($self->getLabelDimensions("$part $_", $properties)->{width} > $maxWidth) {
|
||||
if ($part) {
|
||||
$part =~ s/ $//;
|
||||
push(@lines, $part);
|
||||
$part = "$_ ";
|
||||
} else {
|
||||
push(@lines, $_);
|
||||
$part = '';
|
||||
}
|
||||
} else {
|
||||
$part .= "$_ ";
|
||||
}
|
||||
}
|
||||
$part =~ s/ $//;
|
||||
push(@lines, $part) if ($part);
|
||||
|
||||
return join("\n", @lines);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
1545
lib/WebGUI/Image/Graph/Pie.pm
Normal file
1545
lib/WebGUI/Image/Graph/Pie.pm
Normal file
File diff suppressed because it is too large
Load diff
711
lib/WebGUI/Image/Graph/XYGraph.pm
Normal file
711
lib/WebGUI/Image/Graph/XYGraph.pm
Normal file
|
|
@ -0,0 +1,711 @@
|
|||
package WebGUI::Image::Graph::XYGraph;
|
||||
|
||||
use strict;
|
||||
use WebGUI::Image::Graph;
|
||||
use WebGUI::International;
|
||||
use List::Util;
|
||||
use POSIX;
|
||||
|
||||
our @ISA = qw(WebGUI::Image::Graph);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Image::Graph::XYGraph
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Base class for flat xy charts.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
XY charts are graphs that have a x and a y coordinate. Examples are Line and Bar
|
||||
graphs.
|
||||
|
||||
This package provides basics needs for such graphs like methods for drawing
|
||||
axis, labels, rulers and the likes. Also it has methods to set parameters
|
||||
belonging to xy charts in general such as setting chart width.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 configurationForm ( )
|
||||
|
||||
The configuration form part for this object. See WebGUI::Image::Graph for
|
||||
documentation.
|
||||
|
||||
=cut
|
||||
|
||||
sub configurationForm {
|
||||
my ($configForms, $f);
|
||||
my $self = shift;
|
||||
|
||||
my $i18n = WebGUI::International->new($self->session, 'Image_Graph_XYGraph');
|
||||
|
||||
$configForms = $self->SUPER::configurationForm;
|
||||
|
||||
$f = WebGUI::HTMLForm->new($self->session);
|
||||
$f->trClass('Graph_XYGraph');
|
||||
$f->integer(
|
||||
name => 'xyGraph_chartWidth',
|
||||
value => $self->getChartWidth,
|
||||
label => $i18n->get('chart width'),
|
||||
hoverHelp => $i18n->get('chart width description'),
|
||||
);
|
||||
$f->integer(
|
||||
name => 'xyGraph_chartHeight',
|
||||
value => $self->getChartHeight,
|
||||
label => $i18n->get('chart height'),
|
||||
hoverHelp => $i18n->get('chart height description'),
|
||||
);
|
||||
$f->yesNo(
|
||||
name => 'xyGraph_drawLabels',
|
||||
value => $self->showLabels,
|
||||
label => $i18n->get('draw labels'),
|
||||
hoverHelp => $i18n->get('draw labels description'),
|
||||
);
|
||||
$f->yesNo(
|
||||
name => 'xyGraph_drawAxis',
|
||||
value => $self->showAxis,
|
||||
label => $i18n->get('draw axis'),
|
||||
hoverHelp => $i18n->get('draw axis description'),
|
||||
);
|
||||
$f->color(
|
||||
name => 'xyGraph_axisColor',
|
||||
value => $self->getAxisColor,
|
||||
label => $i18n->get('axis color'),
|
||||
hoverHelp => $i18n->get('axis color description'),
|
||||
);
|
||||
$f->yesNo(
|
||||
name => 'xyGraph_drawRulers',
|
||||
value => $self->showRulers,
|
||||
label => $i18n->get('draw rulers'),
|
||||
hoverHelp => $i18n->get('draw rulers description'),
|
||||
);
|
||||
$f->color(
|
||||
name => 'xyGraph_rulerColor',
|
||||
value => $self->getRulerColor,
|
||||
label => $i18n->get('ruler color'),
|
||||
hoverHelp => $i18n->get('ruler color description'),
|
||||
);
|
||||
$f->selectBox(
|
||||
name => 'xyGraph_drawMode',
|
||||
value => [ $self->getDrawMode ],
|
||||
label => $i18n->get('draw mode'),
|
||||
hoverHelp => $i18n->get('draw mode description'),
|
||||
multiple=> 0,
|
||||
options => {
|
||||
sideBySide => 'Side by side',
|
||||
stacked => 'Stacked (cumulative',
|
||||
},
|
||||
);
|
||||
$f->float(
|
||||
name => 'xyGraph_yGranularity',
|
||||
value => $self->getYGranularity,
|
||||
label => $i18n->get('y granularity'),
|
||||
hoverHelp => $i18n->get('y granularity description'),
|
||||
);
|
||||
|
||||
$configForms->{'graph_xygraph'} = $f->printRowsOnly;
|
||||
return $configForms;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 draw ( )
|
||||
|
||||
Draws the graph.
|
||||
|
||||
=cut
|
||||
|
||||
sub draw {
|
||||
my $self = shift;
|
||||
|
||||
# Automagically set the chart offset.
|
||||
my $maxYLabelWidth = List::Util::max(map {$self->getLabelDimensions($_)->{width}} @{$self->getYLabels});
|
||||
$self->setChartOffset({
|
||||
x=> $maxYLabelWidth + 2*$self->getLabelOffset,
|
||||
y=> $self->getLabelOffset
|
||||
});
|
||||
|
||||
$self->drawRulers if ($self->showRulers);
|
||||
$self->drawGraph;
|
||||
$self->drawAxis if ($self->showAxis);
|
||||
$self->drawLabels if ($self->showLabels);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawAxis ( )
|
||||
|
||||
Draws the axis.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawAxis {
|
||||
my $self = shift;
|
||||
|
||||
my $chartOffset = $self->getChartOffset;
|
||||
$self->image->Draw(
|
||||
primitive => 'Path',
|
||||
stroke => $self->getAxisColor,
|
||||
points =>
|
||||
" M ".$chartOffset->{x}.",".$chartOffset->{y}.
|
||||
" L ".$chartOffset->{x}.",".($self->getChartHeight + $chartOffset->{y}).
|
||||
" L ".($self->getChartWidth + $chartOffset->{x}).",".($self->getChartHeight + $chartOffset->{y}),
|
||||
fill => 'none',
|
||||
);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawLabels ( )
|
||||
|
||||
Draws the labels.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawLabels {
|
||||
my $self = shift;
|
||||
my $location = shift;
|
||||
|
||||
my %anchorPoint = %{$self->getFirstAnchorLocation};
|
||||
|
||||
# Draw x-axis labels
|
||||
foreach my $text (@{$self->getLabel}) {
|
||||
$self->drawLabel($text, (
|
||||
alignVertical => 'top',
|
||||
align => 'left',
|
||||
rotate => 90,
|
||||
x => $anchorPoint{x},
|
||||
y => $anchorPoint{y},
|
||||
));
|
||||
|
||||
$anchorPoint{x} += $self->getAnchorSpacing->{x};
|
||||
$anchorPoint{y} += $self->getAnchorSpacing->{y};
|
||||
}
|
||||
|
||||
# Draw y-axis labels
|
||||
$anchorPoint{x} = $self->getChartOffset->{x} - $self->getLabelOffset;
|
||||
$anchorPoint{y} = $self->getChartOffset->{y} + $self->getChartHeight;
|
||||
foreach (@{$self->getYLabels}) {
|
||||
$self->drawLabel($_, (
|
||||
alignHorizontal => 'right',
|
||||
alignVertical => 'center',
|
||||
x => $anchorPoint{x},
|
||||
y => $anchorPoint{y},
|
||||
));
|
||||
$anchorPoint{y} -= $self->getPixelsPerUnit * $self->getYGranularity
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawRulers ( )
|
||||
|
||||
Draws the rulers.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawRulers {
|
||||
my $self = shift;
|
||||
|
||||
my $chartOffset = $self->getChartOffset;
|
||||
my $dist = $self->getLabelOffset;
|
||||
|
||||
for (1 .. $self->getYRange / $self->getYGranularity) {
|
||||
$self->image->Draw(
|
||||
primitive => 'Path',
|
||||
stroke => $self->getRulerColor,
|
||||
points =>
|
||||
" M ".$chartOffset->{x}.",".($chartOffset->{y}+$self->getChartHeight - $self->getPixelsPerUnit * $_*$self->getYGranularity).
|
||||
" L ".($chartOffset->{x}+$self->getChartWidth).",".($chartOffset->{y}+$self->getChartHeight - $self->getPixelsPerUnit * $_*$self->getYGranularity)
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 formNamespace ( )
|
||||
|
||||
Extends the form namespace for this object. See WebGUI::Image::Graph for
|
||||
documentation.
|
||||
|
||||
=cut
|
||||
|
||||
sub formNamespace {
|
||||
my $self = shift;
|
||||
|
||||
return $self->SUPER::formNamespace.'_XYGraph';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getAnchorSpacing ()
|
||||
|
||||
This method MUST be overridden by all sub classes.
|
||||
|
||||
=cut
|
||||
|
||||
sub getAnchorSpacing {
|
||||
die "You were supposed to override this method in the sub class.";
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getAxisColor ( )
|
||||
|
||||
Returns the color triplet for the axis. Defaults to '#222222'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getAxisColor {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_axisProperties}->{axisColor} || '#222222';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getChartHeight ( )
|
||||
|
||||
Returns the height of the chart. Defaults to 200.
|
||||
|
||||
=cut
|
||||
|
||||
sub getChartHeight {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{chartHeight} || 200;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getChartOffset ( )
|
||||
|
||||
Returns the coordinates of the top-left corner of the chart. he coordinates are
|
||||
contained in a hasref with keys 'x' and 'y'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getChartOffset {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{chartOffset} || { x=>0, y=>0 }
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getChartWidth ( )
|
||||
|
||||
Returns the width of the chart. Defaults to 200.
|
||||
|
||||
=cut
|
||||
|
||||
sub getChartWidth {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{chartWidth} || 200;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getConfiguration ( )
|
||||
|
||||
Returns a configuration hashref. See WebGUI::Image::Graph for documentation.
|
||||
|
||||
=cut
|
||||
|
||||
sub getConfiguration {
|
||||
my $self = shift;
|
||||
|
||||
my $config = $self->SUPER::getConfiguration;
|
||||
|
||||
$config->{xyGraph_chartWidth} = $self->getChartWidth;
|
||||
$config->{xyGraph_chartHeight} = $self->getChartHeight;
|
||||
$config->{xyGraph_drawLabels} = $self->showLabels;
|
||||
$config->{xyGraph_drawAxis} = $self->showAxis;
|
||||
$config->{xyGraph_drawRulers} = $self->showRulers;
|
||||
$config->{xyGraph_drawMode} = $self->getDrawMode;
|
||||
$config->{xyGraph_yGranularity} = $self->getYGranularity;
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getDrawMode ( )
|
||||
|
||||
Returns the drawmode. Currently supported are 'stacked' and 'sideBySide'.
|
||||
Defaults to 'sideBySide'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getDrawMode {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_barProperties}->{drawMode} || 'sideBySide';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getPixelsPerUnit ( )
|
||||
|
||||
Returns the number of pixels that correspond with one unit of the dataset
|
||||
values.
|
||||
|
||||
=cut
|
||||
|
||||
sub getPixelsPerUnit {
|
||||
my $self = shift;
|
||||
|
||||
return $self->getChartHeight / $self->getYRange;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getRulerColor ( )
|
||||
|
||||
Returns the color triplet of the rulers in the graph. Defaults to '#777777'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getRulerColor {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_axisProperties}->{rulerColor} || '#777777';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getYGranularity ( )
|
||||
|
||||
Returns the granularity of the labels and rulers in the Y direction. Defaults to
|
||||
10. This is value is in terms of the values in the dataset and has no direct
|
||||
relation to pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub getYGranularity {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{yGranularity} || 10;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getYLabels ( )
|
||||
|
||||
Returns an arrayref containing the labels for the Y axis.
|
||||
|
||||
=cut
|
||||
|
||||
sub getYLabels {
|
||||
my $self = shift;
|
||||
|
||||
my @yLabels;
|
||||
for (0 .. $self->getYRange / $self->getYGranularity) {
|
||||
push(@yLabels, $_ * $self->getYGranularity);
|
||||
}
|
||||
|
||||
return \@yLabels;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getYRange ( )
|
||||
|
||||
Returns the maxmimal value of the range that contains a whole number of times
|
||||
the y granularity and is bigger than the maximum value in the dataset.
|
||||
|
||||
=cut
|
||||
|
||||
sub getYRange {
|
||||
my $self = shift;
|
||||
|
||||
return $self->getYGranularity*ceil($self->getMaxValueFromDataset / $self->getYGranularity) || 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setAxisColor ( color )
|
||||
|
||||
Sets the color of the axis to the supplied value.
|
||||
|
||||
=head3 color
|
||||
|
||||
The triplet of the color you want to set the axis to. Must have the following
|
||||
form: #ffffff.
|
||||
|
||||
=cut
|
||||
|
||||
sub setAxisColor {
|
||||
my $self = shift;
|
||||
my $color = shift;
|
||||
|
||||
$self->{_axisProperties}->{axisColor} = $color;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setChartHeight ( height )
|
||||
|
||||
Sets the height of the chart to the specified value.
|
||||
|
||||
=head3 height
|
||||
|
||||
The desired height in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub setChartHeight {
|
||||
my $self = shift;
|
||||
my $height = shift;
|
||||
|
||||
$self->{_properties}->{chartHeight} = $height;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setChartOffset ( location )
|
||||
|
||||
Sets the location of the top-left corner of the graph within the image.
|
||||
|
||||
=head3 location
|
||||
|
||||
A hashref containing the desired location. Use the 'x' and 'y' as keys for the x
|
||||
and y coordinate respectively.
|
||||
|
||||
=cut
|
||||
|
||||
sub setChartOffset {
|
||||
my $self = shift;
|
||||
my $point = shift;
|
||||
|
||||
$self->{_properties}->{chartOffset} = {%$point};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setChartWidth ( width )
|
||||
|
||||
Sets the width of the chart to the specified value.
|
||||
|
||||
=head3 width
|
||||
|
||||
The desired width in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub setChartWidth {
|
||||
my $self = shift;
|
||||
my $width = shift;
|
||||
|
||||
$self->{_properties}->{chartWidth} =$width;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setConfiguration ( config )
|
||||
|
||||
Applies the settings in the given configuration hash. See WebGUI::Image::Graph
|
||||
for more information.
|
||||
|
||||
=head3 config
|
||||
|
||||
A configuration hash.
|
||||
|
||||
=cut
|
||||
|
||||
sub setConfiguration {
|
||||
my $self = shift;
|
||||
my $config = shift;
|
||||
|
||||
$self->SUPER::setConfiguration($config);
|
||||
|
||||
$self->setChartWidth($config->{xyGraph_chartWidth});
|
||||
$self->setChartHeight($config->{xyGraph_chartHeight});
|
||||
$self->setShowLabels($config->{xyGraph_drawLabels});
|
||||
$self->setShowAxis($config->{xyGraph_drawAxis});
|
||||
$self->setShowRulers($config->{xyGraph_drawRulers});
|
||||
$self->setDrawMode($config->{xyGraph_drawMode});
|
||||
$self->setYGranularity($config->{xyGraph_yGranularity});
|
||||
$self->setAxisColor($config->{xyGraph_axisColor});
|
||||
$self->setRulerColor($config->{xyGraph_rulerColor});
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setDrawMode ( mode )
|
||||
|
||||
Set the way the datasets are drawn. Currently supported are 'stacked' and
|
||||
'sideBySide' which correspond to respectivly cumulative drawing and normal
|
||||
processing.
|
||||
|
||||
=head3 mode
|
||||
|
||||
The desired mode. Can be 'sideBySide' or 'stacked'.
|
||||
|
||||
=cut
|
||||
|
||||
sub setDrawMode {
|
||||
my $self = shift;
|
||||
my $mode = shift;
|
||||
|
||||
if ($mode eq 'stacked' || $mode eq 'sideBySide') {
|
||||
$self->{_barProperties}->{drawMode} = $mode;
|
||||
} else {
|
||||
$self->{_barProperties}->{drawMode} = 'sideBySide';
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setRulerColor ( color )
|
||||
|
||||
Set the color of the rulers.
|
||||
|
||||
=head3 color
|
||||
|
||||
The triplet of the desired ruler color. Must be in the following format:
|
||||
'#ffffff'.
|
||||
|
||||
=cut
|
||||
|
||||
sub setRulerColor {
|
||||
my $self = shift;
|
||||
my $color = shift;
|
||||
|
||||
$self->{_axisProperties}->{rulerColor} = $color;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setShowAxis ( boolean )
|
||||
|
||||
Set whether or not to draw the axis.
|
||||
|
||||
=head3 boolean
|
||||
|
||||
If set to false the axis won't be drawn.
|
||||
|
||||
=cut
|
||||
|
||||
sub setShowAxis {
|
||||
my $self = shift;
|
||||
my $yesNo = shift;
|
||||
|
||||
$self->{_properties}->{showAxis} = $yesNo;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setShowLabels ( boolean )
|
||||
|
||||
Set whether or not to draw the labels.
|
||||
|
||||
=head3 boolean
|
||||
|
||||
If set to false the labels won't be drawn.
|
||||
|
||||
=cut
|
||||
|
||||
sub setShowLabels {
|
||||
my $self = shift;
|
||||
my $yesNo = shift;
|
||||
|
||||
$self->{_properties}->{showLabels} = $yesNo;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setShowRulers ( boolean )
|
||||
|
||||
Set whether or not to draw the rulers.
|
||||
|
||||
=head3 boolean
|
||||
|
||||
If set to false the rulers won't be drawn.
|
||||
|
||||
=cut
|
||||
|
||||
sub setShowRulers {
|
||||
my $self = shift;
|
||||
my $yesNo = shift;
|
||||
|
||||
$self->{_properties}->{showRulers} = $yesNo;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setYGranularity ( value )
|
||||
|
||||
Sets the y granularity. See getYGranularity for explanation of this concept.
|
||||
|
||||
=head3 value
|
||||
|
||||
The granularity in dataset units, not pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub setYGranularity {
|
||||
my $self = shift;
|
||||
my $granularity = shift;
|
||||
|
||||
$self->{_properties}->{yGranularity} = $granularity;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 showAxis ( )
|
||||
|
||||
Returns a boolean indicating whether to draw the axis.
|
||||
|
||||
=cut
|
||||
|
||||
sub showAxis {
|
||||
my $self = shift;
|
||||
|
||||
return 1 unless (defined $self->{_properties}->{showAxis});
|
||||
return $self->{_properties}->{showAxis};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 showLabels ( )
|
||||
|
||||
Returns a boolean indicating whether to draw the labels.
|
||||
|
||||
=cut
|
||||
|
||||
sub showLabels {
|
||||
my $self = shift;
|
||||
|
||||
return 1 unless (defined $self->{_properties}->{showLabels});
|
||||
return $self->{_properties}->{showLabels};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 showRulers ( )
|
||||
|
||||
Returns a boolean indicating whether to draw the rulers.
|
||||
|
||||
=cut
|
||||
|
||||
sub showRulers {
|
||||
my $self = shift;
|
||||
|
||||
return 1 unless (defined $self->{_properties}->{showRulers});
|
||||
return $self->{_properties}->{showRulers};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
426
lib/WebGUI/Image/Graph/XYGraph/Bar.pm
Normal file
426
lib/WebGUI/Image/Graph/XYGraph/Bar.pm
Normal file
|
|
@ -0,0 +1,426 @@
|
|||
package WebGUI::Image::Graph::XYGraph::Bar;
|
||||
|
||||
use strict;
|
||||
use WebGUI::Image::Graph::XYGraph;
|
||||
use List::Util;
|
||||
use POSIX;
|
||||
use WebGUI::Utility;
|
||||
|
||||
our @ISA = qw(WebGUI::Image::Graph::XYGraph);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Image::Graph::XYGraph::Bar
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Package for creating bar graphs.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This package privides the logic for drawing 2d bar graphs, 3d bars are in the
|
||||
pipeline but not yet ready for prime time.
|
||||
|
||||
This module can draw bar graph in two forms: Stacked and Side by Side. The
|
||||
diffrence is noticable only if more multiple dataset is used, the behaviour is
|
||||
thus identical in case of one dataset.
|
||||
|
||||
Stacked graphs place the bars belonging the same index within diffrent datasets
|
||||
on top of each other given a grand total for all datasets.
|
||||
|
||||
Sid by side graphs place bars with the same index next to each other, grouped by
|
||||
index. This displays a better comaprison between datasets.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 configurationForm
|
||||
|
||||
Creates the configuration form for this plugin. See WebGUI::Image::Graph for
|
||||
more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub configurationForm {
|
||||
my $self = shift;
|
||||
|
||||
my $i18n = WebGUI::International->new($self->session, 'Image_Graph_XYGraph_Bar');
|
||||
|
||||
my $configForms = $self->SUPER::configurationForm;
|
||||
my $f = WebGUI::HTMLForm->new($self->session);
|
||||
$f->trClass('Graph_XYGraph_Bar');
|
||||
$f->float(
|
||||
name => 'xyGraph_bar_barSpacing',
|
||||
value => $self->getBarSpacing,
|
||||
label => $i18n->get('bar spacing'),
|
||||
hoverHelp => $i18n->get('bar spacing description'),
|
||||
);
|
||||
$f->float(
|
||||
name => 'xyGraph_bar_groupSpacing',
|
||||
value => $self->getGroupSpacing,
|
||||
label => $i18n->get('group spacing'),
|
||||
hoverHelp => $i18n->get('group spacing description'),
|
||||
);
|
||||
|
||||
$configForms->{'graph_xygraph_bar'} = $f->printRowsOnly;
|
||||
|
||||
return $configForms;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawBar ( bar, location, barWidth )
|
||||
|
||||
Draws a bar defined by bar and with width barWidth at location.
|
||||
|
||||
=head3 bar
|
||||
|
||||
A hashref defining the bar. Must contain keys 'height', 'strokeColor' and
|
||||
'fillColor'.
|
||||
|
||||
=head3 location
|
||||
|
||||
A hashref containing the location of the bottom-left corner of the bar. Keys 'x'
|
||||
and 'y' must specify the x- and y-coordinates respectively.
|
||||
|
||||
=head3 barWidth
|
||||
|
||||
The width of the bar in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawBar {
|
||||
my $self = shift;
|
||||
my $bar = shift;
|
||||
my $location = shift;
|
||||
my $barWidth = shift;
|
||||
|
||||
my $barHeight = $bar->{height} * $self->getPixelsPerUnit;
|
||||
|
||||
$self->image->Draw(
|
||||
primitive => 'Path',
|
||||
stroke => $bar->{strokeColor},
|
||||
points =>
|
||||
" M ".$location->{x}.",".$location->{y}.
|
||||
" L ".$location->{x}.",".($location->{y}-$barHeight).
|
||||
" L ".($location->{x}+$barWidth).",".($location->{y}-$barHeight).
|
||||
" L ".($location->{x}+$barWidth).",".$location->{y},
|
||||
fill => $bar->{fillColor},
|
||||
);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawGraph
|
||||
|
||||
Draws all the bars.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawGraph {
|
||||
my %location;
|
||||
my $self = shift;
|
||||
|
||||
$self->processDataSet;
|
||||
|
||||
my $numberOfGroups = List::Util::max(map {scalar @$_} @{$self->{_datasets}});
|
||||
my $numberOfDatasets = scalar @{$self->{_datasets}};
|
||||
my $groupWidth = ($self->getChartWidth - ($numberOfGroups-1) * $self->getGroupSpacing) / $numberOfGroups;
|
||||
|
||||
my $barWidth = $groupWidth;
|
||||
$barWidth = ($groupWidth - ($numberOfDatasets - 1) * $self->getBarSpacing) / $numberOfDatasets if ($self->getDrawMode eq 'sideBySide');
|
||||
|
||||
$location{x} = $self->getChartOffset->{x} ;
|
||||
$location{y} = $self->getChartOffset->{y} + $self->getChartHeight;
|
||||
foreach my $currentBar (@{$self->{_bars}}) {
|
||||
if ($self->getDrawMode eq 'stacked') {
|
||||
$self->drawStackedBar($currentBar, \%location, $barWidth);
|
||||
} else {
|
||||
$self->drawSideBySideBar($currentBar, \%location, $barWidth);
|
||||
}
|
||||
|
||||
$location{x} += $groupWidth + $self->getGroupSpacing;
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawSideBySideBar ( bars, location, barWidth )
|
||||
|
||||
Draws the bars in side by side mode. Meaning that per datsetindex the bars
|
||||
representing a single dataset are grouped.
|
||||
|
||||
=head3 bars
|
||||
|
||||
An arrayref containing all the bar description hashrefs as described in drawBar.
|
||||
|
||||
=head3 location
|
||||
|
||||
Hashref containing the initial coordinates of the lower-left corner of the
|
||||
chart. Pass coords in keys 'x' and 'y'.
|
||||
|
||||
=head3 barWidth
|
||||
|
||||
The width of each bar in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawSideBySideBar {
|
||||
my $self = shift;
|
||||
my $bars = shift;
|
||||
my $location = shift;
|
||||
my $barWidth = shift;
|
||||
|
||||
my %thisLocation = %$location;
|
||||
|
||||
foreach (@$bars) {
|
||||
$self->drawBar($_, \%thisLocation, $barWidth);
|
||||
$thisLocation{x} += $barWidth + $self->getBarSpacing;
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawStackedBar ( bars, location, barWidth )
|
||||
|
||||
Draws the bars in side by side mode. Meaning that per datset-index the bars
|
||||
representing a single dataset are stacked on top of each other.
|
||||
|
||||
=head3 bars
|
||||
|
||||
An arrayref containing all the bar description hashrefs as described in drawBar.
|
||||
|
||||
=head3 location
|
||||
|
||||
Hashref containing the initial coordinates of the lower-left corner of the
|
||||
chart. Pass coords in keys 'x' and 'y'.
|
||||
|
||||
=head3 barWidth
|
||||
|
||||
The width of each bar in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
sub drawStackedBar {
|
||||
my $self = shift;
|
||||
my $bars = shift;
|
||||
my $location = shift;
|
||||
my $barWidth = shift;
|
||||
|
||||
my %thisLocation = %$location;
|
||||
foreach (@$bars) {
|
||||
$self->drawBar($_, \%thisLocation, $barWidth);
|
||||
$thisLocation{y} -= $_->{height} * $self->getPixelsPerUnit;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 formNamespace
|
||||
|
||||
Returns the form namespace of this plugin. See WegBUI::Image::Graph for
|
||||
more elaborate information.
|
||||
|
||||
=cut
|
||||
|
||||
sub formNamespace {
|
||||
my $self = shift;
|
||||
|
||||
return $self->SUPER::formNamespace.'_Bar';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getAnchorSpacing
|
||||
|
||||
Returns the distance in pixels between two anchors on the x axis that define teh
|
||||
placement of bars and labels.
|
||||
|
||||
=cut
|
||||
|
||||
sub getAnchorSpacing {
|
||||
my $self = shift;
|
||||
|
||||
my $numberOfGroups = List::Util::max(map {scalar @$_} @{$self->getDataset});
|
||||
|
||||
my $spacing = round(($self->getChartWidth - ($numberOfGroups-1) * $self->getGroupSpacing) / $numberOfGroups + $self->getGroupSpacing);
|
||||
|
||||
return {
|
||||
x => $spacing,
|
||||
y => 0,
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getBarSpacing
|
||||
|
||||
Returns the width of the gap between two bars within a group in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub getBarSpacing {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_barProperties}->{barSpacing} || 0;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getConfiguration
|
||||
|
||||
Returns the configuration hashref for this plugin. Refer to WebGUI::IMage::Graph
|
||||
for a more detailed description.
|
||||
|
||||
=cut
|
||||
|
||||
sub getConfiguration {
|
||||
my $self = shift;
|
||||
|
||||
my $config = $self->SUPER::getConfiguration;
|
||||
|
||||
$config->{xyGraph_bar_barSpacing} = $self->getBarSpacing;
|
||||
$config->{xyGraph_bar_groupSpacing} = $self->getGroupSpacing;
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getGroupSpacing
|
||||
|
||||
Returns the width of the gap between two groups of bars in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub getGroupSpacing {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_barProperties}->{groupSpacing} || $self->getBarSpacing;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFirstAnchorLocation
|
||||
|
||||
Returns a hashref containing the location of the leftmost x-axis anchor.
|
||||
Location coordinates are encoded in keys 'x' and 'y'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getFirstAnchorLocation {
|
||||
my $self = shift;
|
||||
|
||||
return {
|
||||
x => round($self->getChartOffset->{x} + ($self->getAnchorSpacing->{x} - $self->getGroupSpacing) / 2),
|
||||
y => $self->getChartOffset->{y} + $self->getChartHeight
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 processDataSet
|
||||
|
||||
Processes the dataset. Used by drawGraph.
|
||||
|
||||
=cut
|
||||
|
||||
sub processDataSet {
|
||||
my ($barProperties);
|
||||
my $self = shift;
|
||||
|
||||
my $palette = $self->getPalette;
|
||||
|
||||
my $maxElements = List::Util::max(map {scalar @$_} @{$self->{_datasets}});
|
||||
my $numberOfDatasets = scalar @{$self->{_datasets}};
|
||||
|
||||
for my $currentElement (0 .. $maxElements-1) {
|
||||
my @thisSet = ();
|
||||
for my $currentDataset (0 .. $numberOfDatasets - 1) {
|
||||
my $color = $palette->getColor($currentDataset);
|
||||
if ($numberOfDatasets == 1) {
|
||||
$color = $palette->getNextColor;
|
||||
}
|
||||
push(@thisSet, {
|
||||
height => $self->{_datasets}->[$currentDataset]->[$currentElement] || 0,
|
||||
fillColor => $color->getFillColor,
|
||||
strokeColor => $color->getStrokeColor,
|
||||
});
|
||||
}
|
||||
push(@{$self->{_bars}}, [ @thisSet ]);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setBarSpacing ( gap )
|
||||
|
||||
Sets the distance between two bars in a group in pixels.
|
||||
|
||||
=head3 gap
|
||||
|
||||
The distance in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub setBarSpacing {
|
||||
my $self = shift;
|
||||
my $gap = shift;
|
||||
|
||||
$self->{_barProperties}->{barSpacing} = $gap;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setConfiguration ( config )
|
||||
|
||||
Applies the given configuration hash to this plugin. See WebGUI::Image::Graph
|
||||
for more info.
|
||||
|
||||
=head3 config
|
||||
|
||||
The configuration hash.
|
||||
|
||||
=cut
|
||||
|
||||
sub setConfiguration {
|
||||
my $self = shift;
|
||||
my $config = shift;
|
||||
|
||||
$self->SUPER::setConfiguration($config);
|
||||
|
||||
$self->setBarSpacing($config->{xyGraph_bar_barSpacing});
|
||||
$self->setGroupSpacing($config->{xyGraph_bar_groupSpacing});
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setGroupSpacing ( gap )
|
||||
|
||||
Sets the distance between two groups of bars in pixels.
|
||||
|
||||
=head3 gap
|
||||
|
||||
The distance in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
sub setGroupSpacing {
|
||||
my $self = shift;
|
||||
my $gap = shift;
|
||||
|
||||
$self->{_barProperties}->{groupSpacing} = $gap;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
184
lib/WebGUI/Image/Graph/XYGraph/Line.pm
Normal file
184
lib/WebGUI/Image/Graph/XYGraph/Line.pm
Normal file
|
|
@ -0,0 +1,184 @@
|
|||
package WebGUI::Image::Graph::XYGraph::Line;
|
||||
|
||||
use strict;
|
||||
use WebGUI::Image::Graph::XYGraph;
|
||||
use List::Util;
|
||||
use POSIX;
|
||||
|
||||
our @ISA = qw(WebGUI::Image::Graph::XYGraph);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Image::Graph::XYGraph::Line
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Package for creating line graphs.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This package privides the logic for drawing 2d line graphs, 3d lines are in the
|
||||
pipeline but not yet ready for prime time.
|
||||
|
||||
The possibilities are quite limited for now but will be enhanced upon in the future.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawGraph
|
||||
|
||||
Draws all the lines.
|
||||
|
||||
=cut
|
||||
|
||||
sub drawGraph {
|
||||
my ($currentBar, %location);
|
||||
my $self = shift;
|
||||
|
||||
$self->processDataSet;
|
||||
|
||||
my $numberOfGroups = List::Util::max(map {scalar @$_} @{$self->{_datasets}});
|
||||
my $interval = $self->getChartWidth / ($numberOfGroups - 1);
|
||||
|
||||
%location = %{$self->getChartOffset};
|
||||
$location{y} += $self->getChartHeight;
|
||||
|
||||
foreach (@{$self->{_lines}}) {
|
||||
$self->drawLine($_, \%location, $interval);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 drawLine ( line, location, interval )
|
||||
|
||||
Draws a bar defined by bar and with width barWidth at location.
|
||||
|
||||
=head3 line
|
||||
|
||||
A hashref defining the line. Must contain keys 'strokeColor' and
|
||||
'dataset', the latter one being an arrayref containing all points of the line.
|
||||
|
||||
=head3 location
|
||||
|
||||
A hashref containing the location of the bottom-left corner of the line's
|
||||
origin. Keys 'x' and 'y' must specify the x- and y-coordinates respectively.
|
||||
|
||||
=head3 interval
|
||||
|
||||
The distance between x-axis anchors in pixels.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
sub drawLine {
|
||||
my $self = shift;
|
||||
my $line = shift;
|
||||
my $location = shift;
|
||||
my $interval = shift;
|
||||
|
||||
my %currentLocation = %$location;
|
||||
|
||||
|
||||
my $dataCounter;
|
||||
my $path;# = " M ".$currentLocation{x}.",".$currentLocation{y};
|
||||
foreach (@{$line->{dataset}}) {
|
||||
$path .= ($dataCounter++) ? " L " : " M ";
|
||||
$path .= $currentLocation{x}.",".($currentLocation{y} - $_*$self->getPixelsPerUnit);
|
||||
|
||||
$currentLocation{x} += $interval;
|
||||
}
|
||||
|
||||
$self->image->Draw(
|
||||
primitive => 'Path',
|
||||
stroke => $line->{strokeColor},
|
||||
points => $path,
|
||||
fill => 'none',
|
||||
);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 formNamespace
|
||||
|
||||
Returns the form namespace of this plugin. See WegBUI::Image::Graph for
|
||||
more elaborate information.
|
||||
|
||||
=cut
|
||||
|
||||
sub formNamespace {
|
||||
my $self = shift;
|
||||
|
||||
return $self->SUPER::formNamespace.'_Line';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getAnchorSpacing
|
||||
|
||||
Returns the distance in pixels between two anchors on the x axis that define teh
|
||||
placement of bars and labels.
|
||||
|
||||
=cut
|
||||
|
||||
sub getAnchorSpacing {
|
||||
my $self = shift;
|
||||
|
||||
my $numberOfGroups = List::Util::max(map {scalar @$_} @{$self->getDataset});
|
||||
|
||||
my $spacing = $self->getChartWidth / ($numberOfGroups - 1);
|
||||
|
||||
return {
|
||||
x => $spacing,
|
||||
y => 0,
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getFirstAnchorLocation
|
||||
|
||||
Returns a hashref containing the location of the leftmost x-axis anchor.
|
||||
Location coordinates are encoded in keys 'x' and 'y'.
|
||||
|
||||
=cut
|
||||
|
||||
sub getFirstAnchorLocation {
|
||||
my $self = shift;
|
||||
|
||||
return {
|
||||
x => $self->getChartOffset->{x},
|
||||
y => $self->getChartOffset->{y} + $self->getChartHeight
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 processDataSet
|
||||
|
||||
Processes the dataset. Used by drawGraph.
|
||||
|
||||
=cut
|
||||
|
||||
sub processDataSet {
|
||||
my ($barProperties);
|
||||
my $self = shift;
|
||||
|
||||
my $palette = $self->getPalette;
|
||||
foreach (@{$self->{_datasets}}) {
|
||||
push (@{$self->{_lines}}, {
|
||||
dataset => $_,
|
||||
strokeColor => $palette->getColor->getStrokeColor,
|
||||
});
|
||||
$palette->getNextColor;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
524
lib/WebGUI/Image/Palette.pm
Normal file
524
lib/WebGUI/Image/Palette.pm
Normal file
|
|
@ -0,0 +1,524 @@
|
|||
package WebGUI::Image::Palette;
|
||||
|
||||
use strict;
|
||||
use WebGUI::Image::Color;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Image::Palette
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Package for managing WebGUI palettes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Palettes are a list of WebGUI::Image::Color objects. Selecting a specific color
|
||||
can be done by either passing a palette index, or by an API that cyles through
|
||||
the palette.
|
||||
|
||||
Along with methods for these operations methods for editing palettes are
|
||||
provided from this class.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 addColor ( color )
|
||||
|
||||
Adds a color to this palette. The color will be automatically saved or updated
|
||||
to the database.
|
||||
|
||||
=head3 color
|
||||
|
||||
A WebGUI::Image::Color object.
|
||||
|
||||
=cut
|
||||
|
||||
sub addColor {
|
||||
my $self = shift;
|
||||
my $color = shift;
|
||||
|
||||
$color->save;
|
||||
|
||||
$self->session->db->write('insert into imagePaletteColors (paletteId, colorId, paletteOrder) values (?,?,?)', [
|
||||
$self->getId,
|
||||
$color->getId,
|
||||
$self->getNumberOfColors + 1
|
||||
]);
|
||||
|
||||
push (@{$self->{_palette}}, $color);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canDelete ( )
|
||||
|
||||
Returns true if this palette can be deleted.
|
||||
|
||||
=cut
|
||||
|
||||
sub canDelete {
|
||||
my $self = shift;
|
||||
|
||||
return 0 if ($self->getId =~ /^default/);
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canEdit ( )
|
||||
|
||||
Returns true if this palette can be edited.
|
||||
|
||||
=cut
|
||||
|
||||
sub canEdit {
|
||||
my $self = shift;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete ( )
|
||||
|
||||
Deletes the palette from the database. This is only possible if the canDelete
|
||||
method returns true.
|
||||
|
||||
NOTE: For now the colors in the palette are not deleted automatically.
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->canDelete) {
|
||||
$self->session->db->write('delete from imagePaletteColors where paletteId=?', [
|
||||
$self->getId,
|
||||
]);
|
||||
$self->session->db->write('delete from imagePalette where paletteId=?', [
|
||||
$self->getId,
|
||||
]);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getColor ( [ index ] )
|
||||
|
||||
Returns the color at index in the palette. If index is not passed it will return
|
||||
the color at the index specified by the internal palette index counter, ie. the
|
||||
current color.
|
||||
|
||||
=cut
|
||||
|
||||
sub getColor {
|
||||
my $self = shift;
|
||||
my $index = shift || $self->getPaletteIndex;
|
||||
|
||||
return $self->{_palette}->[$index];
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getColorIndex ( color )
|
||||
|
||||
Returns the index of color. If the color is not in the palette it will return
|
||||
undef.
|
||||
|
||||
=head3 color
|
||||
|
||||
A WebGUI::Image::Color object.
|
||||
|
||||
=cut
|
||||
|
||||
sub getColorIndex {
|
||||
my (@palette, $index);
|
||||
my $self = shift;
|
||||
my $color = shift;
|
||||
|
||||
@palette = @{$self->getColorsInPalette};
|
||||
|
||||
for ($index = 0; $index < scalar(@palette); $index++) {
|
||||
return $index if ($self->getColor($index)->getId eq $color->getId);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getColorsInPalette ( )
|
||||
|
||||
Returns a arrayref containing all color objects in the palette.
|
||||
|
||||
=cut
|
||||
|
||||
sub getColorsInPalette {
|
||||
my $self = shift;
|
||||
|
||||
# Copy ref so people cannot overwrite
|
||||
return [ @{$self->{_palette}} ];
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getDefaultPaletteId ( )
|
||||
|
||||
Returns the id of the default palette.
|
||||
|
||||
=cut
|
||||
|
||||
sub getDefaultPaletteId {
|
||||
my $self = shift;
|
||||
|
||||
return 'defaultPalette';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getId ( )
|
||||
|
||||
Returns the guid of this palette.
|
||||
|
||||
=cut
|
||||
|
||||
sub getId {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{paletteId};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getName ( )
|
||||
|
||||
Returns the name of this palette.
|
||||
|
||||
=cut
|
||||
|
||||
sub getName {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_properties}->{name};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getNextColor ( )
|
||||
|
||||
Returns the next color in the palette relative to the internal palette index
|
||||
counter, and increases this counter to that color. If the counter already is at
|
||||
the last color in the palette it will cycle around to the first color in the
|
||||
palette.
|
||||
|
||||
=cut
|
||||
|
||||
sub getNextColor {
|
||||
my $self = shift;
|
||||
|
||||
my $index = $self->getPaletteIndex + 1;
|
||||
$index = 0 if ($index >= $self->getNumberOfColors);
|
||||
|
||||
$self->setPaletteIndex($index);
|
||||
return $self->getColor;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getNumberOfColors ( )
|
||||
|
||||
Returns the number of colors in the palette.
|
||||
|
||||
=cut
|
||||
|
||||
sub getNumberOfColors {
|
||||
my $self = shift;
|
||||
|
||||
return scalar(@{$self->{_palette}});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getPaletteIndex ( )
|
||||
|
||||
Returns the index the internal palette index counter is set to. Ie. it returns
|
||||
the current color.
|
||||
|
||||
=cut
|
||||
|
||||
sub getPaletteIndex {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_paletteIndex};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getPaletteList ( )
|
||||
|
||||
Returns a hashref containing a list of all available palettes. The keys are the
|
||||
palette id's and the value are the names of the palettes.
|
||||
|
||||
=cut
|
||||
|
||||
sub getPaletteList {
|
||||
my $self = shift;
|
||||
my $session = shift || $self->session;
|
||||
|
||||
return $session->db->buildHashRef('select paletteId, name from imagePalette');
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getPreviousColor ( )
|
||||
|
||||
Returns the previous color in the palette relative to the internal palette index
|
||||
counter, and decreases this counter to that color. If the counter already is at
|
||||
the first color in the palette it will cycle around to the last color in the
|
||||
palette.
|
||||
|
||||
=cut
|
||||
|
||||
sub getPreviousColor {
|
||||
my $self = shift;
|
||||
|
||||
my $index = $self->{_paletteIndex} - 1;
|
||||
$index = $self->getNumberOfColors - 1 if ($index < 0);
|
||||
|
||||
$self->setPaletteIndex($index);
|
||||
return $self->getColor($index);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new ( session, paletteId, [ name ] )
|
||||
|
||||
Constructor for this class.
|
||||
|
||||
=head3 session
|
||||
|
||||
A WebGUI::Session object.
|
||||
|
||||
=head3 paletteId
|
||||
|
||||
The guid of the palette you want to instanciate. If you want to create a new
|
||||
palette use 'new' for this value.
|
||||
|
||||
=head3 name
|
||||
|
||||
The name of this palette. If not given it will default to 'untitled'. You can
|
||||
also adjust this parameter through the setName method.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($properties, $colors);
|
||||
my $class = shift;
|
||||
my $session = shift;
|
||||
my $paletteId = shift;
|
||||
my $name = shift || 'untitled';
|
||||
|
||||
if ($paletteId eq 'new') {
|
||||
$paletteId = $session->id->generate;
|
||||
$session->db->write('insert into imagePalette (paletteId, name) values (?,?)', [
|
||||
$paletteId,
|
||||
$name
|
||||
]);
|
||||
$properties = {
|
||||
paletteId => $paletteId,
|
||||
name => 'paletteName',
|
||||
};
|
||||
$colors = [];
|
||||
} else {
|
||||
$properties = $session->db->quickHashRef('select * from imagePalette where paletteId = ?', [
|
||||
$paletteId,
|
||||
]);
|
||||
|
||||
unless ($properties->{paletteId}) {
|
||||
$properties = $session->db->quickHashRef('select * from imagePalette where paletteId = ?', [
|
||||
'defaultPalette' #$self->getDefaultPaletteId
|
||||
]);
|
||||
$paletteId = 'defaultPalette';
|
||||
}
|
||||
|
||||
$colors = WebGUI::Image::Color->newByPalette($session, $paletteId);
|
||||
}
|
||||
|
||||
bless {_paletteIndex => 0, _palette => $colors, _properties => $properties, _session => $session}, $class;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 removeColor ( index )
|
||||
|
||||
Removes color at index.
|
||||
|
||||
NOTE: This method does not delete the color from the database. If you want to do
|
||||
this you must do it manually.
|
||||
|
||||
=head3 index
|
||||
|
||||
The index of the color you want to remove. If not given nothing will happen.
|
||||
|
||||
=cut
|
||||
|
||||
sub removeColor {
|
||||
my $self = shift;
|
||||
my $paletteIndex = shift;
|
||||
|
||||
return undef unless (defined $paletteIndex);
|
||||
|
||||
my $color = $self->getColor($paletteIndex);
|
||||
|
||||
splice(@{$self->{_palette}}, $paletteIndex, 1);
|
||||
|
||||
$self->session->db->write('delete from imagePaletteColors where paletteId=? and colorId=?', [
|
||||
$self->getId,
|
||||
$color->getId,
|
||||
]);
|
||||
$self->session->db->write('update imagePaletteColors set paletteOrder=paletteOrder-1 where paletteId=? and paletteOrder > ?', [
|
||||
$self->getId,
|
||||
$paletteIndex,
|
||||
]);
|
||||
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 session ( )
|
||||
|
||||
Returns the WebGUI::Session object.
|
||||
|
||||
=cut
|
||||
|
||||
sub session {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{_session};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setColor ( index, color )
|
||||
|
||||
Sets palette position index to color. This method will automatically save or
|
||||
update the color. Index must be within the current palette. To add additional
|
||||
colors use the addColor method.
|
||||
|
||||
=head3 index
|
||||
|
||||
The index within the palette where you want to put the color.
|
||||
|
||||
=head3 color
|
||||
|
||||
The WebGUI::Image::Color object.
|
||||
|
||||
=cut
|
||||
|
||||
sub setColor {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
my $color = shift;
|
||||
|
||||
return undef if ($index >= $self->getNumberOfColors);
|
||||
return undef if ($index < 0);
|
||||
return undef unless (defined $index);
|
||||
return undef unless (defined $color);
|
||||
|
||||
$color->save;
|
||||
|
||||
$self->session->db->write('update imagePaletteColors set colorId=? where paletteId=? and paletteOrder=?', [
|
||||
$color->getId,
|
||||
$self->getId,
|
||||
$index + 1,
|
||||
]);
|
||||
|
||||
$self->{_palette}->[$index] = $color;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setName ( name )
|
||||
|
||||
Set the name of this palette.
|
||||
|
||||
=head3 name
|
||||
|
||||
A scalar containing the desired name.
|
||||
|
||||
=cut
|
||||
|
||||
sub setName {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
|
||||
$self->session->db->write('update imagePalette set name=? where paletteId=?', [
|
||||
$name,
|
||||
$self->getId,
|
||||
]);
|
||||
|
||||
$self->{_properties}->{name} = $name;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 setPaletteIndex ( index )
|
||||
|
||||
Set the internal palette index counter. In other words, it sets the current
|
||||
color to the specified index. If index exceeds the maximum index number it will
|
||||
be set to the maximum index.
|
||||
|
||||
=head3 index
|
||||
|
||||
The index you want to set the counter to.
|
||||
|
||||
=cut
|
||||
|
||||
sub setPaletteIndex {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
|
||||
return undef unless (defined $index);
|
||||
|
||||
$index = ($self->getNumberOfColors - 1) if ($index >= $self->getNumberOfColors);
|
||||
$index = 0 if ($index < 0);
|
||||
|
||||
$self->{_paletteIndex} = $index;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 swapColors ( firstIndex, secondIndex )
|
||||
|
||||
Swaps the position of two colors within the palette.
|
||||
|
||||
=head3 firstIndex
|
||||
|
||||
The index of one of the colors to swap.
|
||||
|
||||
=head3 secondIndex
|
||||
|
||||
The index of the other color to swap.
|
||||
|
||||
=cut
|
||||
|
||||
sub swapColors {
|
||||
my $self = shift;
|
||||
my $indexA = shift;
|
||||
my $indexB = shift;
|
||||
|
||||
my $colorA = $self->getColor($indexA);
|
||||
my $colorB = $self->getColor($indexB);
|
||||
|
||||
$self->setColor($indexA, $colorB);
|
||||
$self->setColor($indexB, $colorA);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue