File Coverage

blib/lib/SVG/GD.pm

Criterion	Covered	Total	%
statement	32	204	15.6
branch	0	18	0.0
condition	0	6	0.0
subroutine	11	56	19.6
pod	6	6	100.0
total	49	290	16.9

package SVG::GD;

$VERSION = '0.20';

no  strict 'refs';

use SVG;
use Exporter;
use warnings;

=pod

=head1 Name: SVG::GD

=head1 Version 0.20

=head1 Author: Ronan Oger

=head1 Abstract

Provide (as seamless as possible) an SVG wrapper to the GD API
in order to provide SVG output of images generate with the Perl GD module

=head1 Synopsis

	use GD;
	use SVG::GD;
	$im = new GD::Image(100,50);

	# allocate black -- this will be our background
	$black = $im->colorAllocate(0, 0, 0);

	# allocate white
	$white = $im->colorAllocate(255, 255, 255);

	# allocate red
	$red = $im->colorAllocate(255, 0, 0);

	# allocate blue
	$blue = $im->colorAllocate(0,0,255);

	#Inscribe an ellipse in the image
	$im->arc(50, 25, 98, 48, 0, 360, $white);

	# Flood-fill the ellipse. Fill color is red, and will replace the
	# black interior of the ellipse
	$im->fill(50, 21, $red);

	binmode STDOUT;

	# print the image to stdout
	print $im->png;

=cut


BEGIN {
	#first, let's re-map the GD::Image methods to somewhere else safe.
	#nb we will also have to do this with the GD::Font methods
#	*SVG::HGD::Image::new = \&GD::Image::new;
#	*SVG::HGD::gdSmallFont =\&GD::gdSmallFont;
#	*SVG::HGD::gdLargeFont =\&GD::gdLargeFont;
#	*SVG::HGD::gdMediumBoldFont =\&GD::gdMediumBoldFont;
#	*SVG::HGD::gdTinyFont =\&GD::gdTinyFont;
#	*SVG::HGD::gdGiantFont =\&GD::gdGiantFont;
#	*SVG::HGD::Image::_make_filehandle =\&GD::Image::_make_filehandle;
#	*SVG::HGD::Image::new =\&GD::Image::new;
#	*SVG::HGD::Image::newTrueColor =\&GD::Image::newTrueColor;
#	*SVG::HGD::Image::newPalette =\&GD::Image::newPalette;
#	*SVG::HGD::Image::newFromPng =\&GD::Image::newFromPng;
#	*SVG::HGD::Image::newFromJpeg =\&GD::Image::newFromJpeg;
#	*SVG::HGD::Image::newFromXbm =\&GD::Image::newFromXbm;
#	*SVG::HGD::Image::newFromGd =\&GD::Image::newFromGd;
#	*SVG::HGD::Image::newFromGd2 =\&GD::Image::newFromGd2;
#	*SVG::HGD::Image::newFromGd2Part =\&GD::Image::newFromGd2Part;
#	*SVG::HGD::Image::ellipse =\&GD::Image::ellipse;
#	*SVG::HGD::Image::clone =\&GD::Image::clone;
#	*SVG::HGD::Polygon::new =\&GD::Polygon::new;
#	*SVG::HGD::Polygon::DESTROY =\&GD::Polygon::DESTROY;
#	*SVG::HGD::Polygon::addPt =\&GD::Polygon::addPt;
#	*SVG::HGD::Polygon::getPt =\&GD::Polygon::getPt;
#	*SVG::HGD::Polygon::setPt =\&GD::Polygon::setPt;
#	*SVG::HGD::Polygon::length =\&GD::Polygon::length;
#	*SVG::HGD::Polygon::vertices =\&GD::Polygon::vertices;
#	*SVG::HGD::Polygon::bounds =\&GD::Polygon::bounds;
#	*SVG::HGD::Polygon::deletePt =\&GD::Polygon::deletePt;
#	*SVG::HGD::Polygon::offset =\&GD::Polygon::offset;
#	*SVG::HGD::Polygon::map =\&GD::Polygon::map;
#	*SVG::HGD::Image::polygon =\&GD::Image::polygon;
#	*SVG::HGD::Polygon::toPt =\&GD::Polygon::toPt;
#	*SVG::HGD::Polygon::transform =\&GD::Polygon::transform;
#	*SVG::HGD::Polygon::scale =\&GD::Polygon::scale;

	*GD::Font:: = *SVG::GD::Font::;
	*GD::Image:: = *SVG::GD::Image::;
}

use vars qw/$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;

our $tinyfontsize='5';
our $smallfontsize='7';
our $mediumfontsize='10';
our $largefontsize='12';
our $giantfontsize='16';
our $font = {};
our $fontindex = 0;

@ISA = qw/Exporter/;

@EXPORT = qw/
	gdBrushed
    gdDashSize
	gdMaxColors
	gdStyled
	gdStyledBrushed
	gdTiled
	gdTransparent
	gdSmallFont
	gdMediumBoldFont
	gdLargeFont
	gdGiantFont /;

@EXPORT_OK = qw/
    GD_CMP_IMAGE
	GD_CMP_NUM_COLORS
	GD_CMP_COLOR
	GD_CMP_SIZE_X
	GD_CMP_SIZE_Y
	GD_CMP_TRANSPARENT
	GD_CMP_BACKGROUND
	GD_CMP_INTERLACE
	GD_CMP_TRUECOLOR /;

%EXPORT_TAGS = ('cmp'  => [	qw/
		GD_CMP_IMAGE
		GD_CMP_NUM_COLORS
		GD_CMP_COLOR
		GD_CMP_SIZE_X
		GD_CMP_SIZE_Y
		GD_CMP_TRANSPARENT
		GD_CMP_BACKGROUND
		GD_CMP_INTERLACE
		GD_CMP_TRUECOLOR / ]
);

=head2 gdTinyFont

returns SVG::GD::Font::Tiny

=cut

#font control


sub SVG::GD::gdTinyFont {
	return SVG::GD::Font::Tiny();
}

#font control

=head2 gdSmallFont

returns SVG::GD::Font::Small();

=cut


sub SVG::GD::gdSmallFont {
	return SVG::GD::Font::Small();
}

=head2 gdMediumBoldFont

returns SVG::GD::Font::Bold();

=cut

#font control
sub SVG::GD::gdMediumBoldFont {
	return SVG::GD::Font::MediumBold();
}

=head2 gdLargeFont

Returns SVG::GD::Font::Large()

=cut

#font control
sub SVG::GD::gdLargeFont {
	return SVG::GD::Font::Large();
}


=head2 gdGiantFont

Returns SVG::GD::Font::Giant()

=cut


#font control

sub SVG::GD::gdGiantFont {
	return SVG::GD::Font::Giant();
}

=head2 gdBrushed

Does nothing at this time

=cut

sub SVG::GD::gdBrushed {
	return '';
}

#
#
# OO font support (encountered in GD::Graph::radar)
#
#

package SVG::GD::Font;

use strict;
use Data::Dumper;
use warnings;

sub registerFont($) {
	my $size = shift;
	$fontindex++;
	$font->{$fontindex}->{fontheight} = $size;
	$font->{$fontindex}->{fontstyle} = {'font-size'=>$size};
	return $fontindex;
}

sub Giant {
    my $class = shift;
    my $size = $giantfontsize;
	SVG::GD::Font::registerFont($size);
}

sub Large {
    my $class = shift;
    my $size = $largefontsize;
	SVG::GD::Font::registerFont($size);
}

sub Medium {
    my $class = shift;
    my $size = $mediumfontsize;
	SVG::GD::Font::registerFont($size);
}

sub MediumBold {
    my $class = shift;
    my $size = $mediumfontsize;
	SVG::GD::Font::registerFont($size);
}

sub Small {
    my $class = shift;
    my $size = $smallfontsize;
	SVG::GD::Font::registerFont($size);
}

sub Tiny {
    my $class = shift;
    my $size = $tinyfontsize;
	SVG::GD::Font::registerFont($size);
}

sub height {
	my $id = shift;
	return 10;
}

sub width {
	my $myfont = shift;
	return 8;
}

=head2 getSVGstyle($font)

retrieve the style in SVG format for predefined fomts

=cut

sub getSVGstyle {
	my $myfont = shift;
	if (eval{defined $font->{$myfont}->{fontstyle} eq 'HASH'}) {
		return %{$font->{$myfont}->{fontstyle}};
	} else {
		return ();
	}

}
#
# SVG::GD::Image
#

package SVG::GD::Image;

use warnings;
use strict;

#constructor
sub SVG::GD::Image::new {
    my $class = shift;
	my $self = {};
	bless $self, $class;
   	#$self->{_GD_} = new SVG::HGD::Image(@_)
	#		|| print STDERR "Quitting. Unable to construct new SVG::HGD::Image
	#	object using SVG::GD!: $!\n";
	#return undef unless defined $self->{_GD_};

	my ($val_1,$val_2,$val_3) = @_;
	#do we have drawing sizes?
	if ($val_1 =~ /^\d+$/ && $val_2 =~ /^\d+$/) {
		$self->{_ATTRIBUTES_}->{width} = $val_1;
		$self->{_ATTRIBUTES_}->{height} = $val_2;
		$self->{_ATTRIBUTES_}->{-truecolor} = $val_3
			if defined $val_3;

	}
	#do we have a valid filename?
	elsif (-r $val_1) {
		$self->{_ATTRIBUTES_}->{FILENAME} = $val_1;
	}
	#do we have a file reference?
	elsif (ref $val_1) {
		$self->{_ATTRIBUTES_}->{FILEHANDLE} = $val_1;
	}
	#then we have raw image data.
	elsif (defined $val_1) {
		$self->{_ATTRIBUTES_}->{IMAGEDATA} = $val_1;
	}
	else {return undef}
	#build the svg drawing
	$self->{_SVG_} = SVG->new(%{$self->{_ATTRIBUTES_}});
	$self->{scratch}->{index_colours} = 0;
	$self->{_COLOUR_}->{named} = {
		white => {svg=>'white',rgb=>'white'},
		lgray => {svg=>'gray',rgb=>'lgray'},
		gray  => {svg=>'gray',rgb=>'gray'},
		dgray => {svg=>'gray',rgb=>'dgray'},
		black =>{svg=>'black',rgb=>'black'},
		lblue =>{svg=>'lightblue',rgb=>'lblue'},
		blue => {svg=>'blue',rgb=>'blue'},
		dblue =>, {svg=>'darkblue',rgb=>'dblue'},
		gold => {svg=>'gold',rgb=>'gold'},
		lyellow =>{svg=>'yellow',rgb=>'lyellow'},
		yellow =>{svg=>'yellow',rgb=>'yellow'},
		dyellow =>{svg=>'gold',rgb=>'gold'},
		lgreen =>{svg=>'mintgreen',rgb=>'lgreen'},
		green =>{svg=>'green',rgb=>'green'},
		dgreen =>{svg=>'darkgreen',rgb=>'dgreen'},
		lred =>{svg=>'red',rgb=>'dred'},
		red => {svg=>'red',rgb=>'red'},
		dred =>{svg=>'red',rgb=>'dred'},
		lpurple =>{svg=>'gold',rgb=>'gold'},
		purple => {svg=>'purple',rgb=>'purple'},
		dpurple =>{svg=>'dpurple ',rgb=>'dpurple'},
		lorange =>{svg=>'lorange ',rgb=>'lorange'},
		orange => {svg=>'orange',rgb=>'orange'},
		pink => {svg=>'pink',rgb=>'pink'},
		dpink =>{svg=>'pink',rgb=>'dpink'},
		marine =>{svg=>'navy',rgb=>'marine'},
		cyan => {svg=>'cyan',rgb=>'cyan'},
		lbrown =>{svg=>'brown',rgb=>'lbrown'},
		dbrown => {svg=>'brown',rgb=>'dbrown'},
		};
	return $self;
}


#--------------------
#Wrapper methods

=head2 setPixel

set a pixel to a colour
Because SVG does not understand pixels, this method has to be faked. We know
from the image size what is meant by a pixel, so we create a rectangle of size
1x1 and give it a colour

=cut

sub SVG::GD::Image::setPixel($$$$) {
	my $self = shift;
	my ($x,$y,$colour) = @_;
	$self->{_SVG_}->rect(x=>$x,y=>$y,
		width=>1,height=>1,
		fill=>$self->getColour($colour));
#	$self->{_GD_}->setPixel($x,$y,$colour);
}


=head2 colorAllocate

Allocate the colour to a variable (red,green,blue)

=cut

sub SVG::GD::Image::colorAllocate($$$$) {
	my $self = shift;
	my ($red,$green,$blue) = @_;
#	my $code = $self->{_GD_}->colorAllocate($red,$green,$blue);
	#if we get an rgb triplet, handle as an rgb triplet
	my $code = $self->{index_colour}++;

	if (defined $green && defined $blue) {
		#$code = "$red.$green.$blue" if (defined $green && defined $blue);
		$self->{_COLOUR_}->{$code}->{svg} =
		$self->{_SVG_}->colorAllocate($red,$green,$blue);
		$self->{_COLOUR_}->{$code}->{rgb} = [$red,$green,$blue];
	}
	#otherwise assume this is a named colour.
	else {
		$code = $red;
		$self->{_COLOUR_}->{$code}->{rgb} = [$code];
		$self->{_COLOUR_}->{$code}->{svg} = [$code];
	}
	return $code;
}

=head2 colorResolve ($red,$green,$blue)

for an rbg tripplet, either returns the index for the colour or generates a new
index for that colour

=cut

*SVG::GD::Image::colorResolve = \&SVG::GD::Image::colorAllocate;

=head2 colorsTotal

return the number of allocated colors

=cut

sub SVG::GD::Image::colorsTotal ($) {
	my $self = shift;
	return scalar(keys %{$self->{_COLOUR_}});
}

=head2 colorExact

check for the existance of an exact color

=cut

sub SVG::GD::Image::colorExact ($$) {
	my $self = shift;
	my $colour = shift;
	return 1 if $self->{_COLOUR_}->{$colour};
	return -1;
}

=head2 colorClosest

returns the closest colour to the RGB triplet being submitted

=cut

sub SVG::GD::Image::colorClosest ($$$$) {
	my $self = shift;
	my ($red,$green,$blue) = @_;
	my $value = {};
	map {
		my $cc = $_;
		#calculate the least-square distance
		my ($dr,$dg,$db) = (
			$red * $red -
			$self->{_COLOUR_}->{$cc}->[0] * $self->{_COLOUR_}->{$cc}->[0],
			$green * $blue -
			$self->{_COLOUR_}->{$cc}->[1] * $self->{_COLOUR_}->{$cc}->[1],
			$blue * $blue -
			$self->{_COLOUR_}->{$cc}->[2] * $self->{_COLOUR_}->{$cc}->[2],
		);

		$value->{$dr+$dg+$db} = $cc;

	}  keys %{$self->{_COLOUR_}};
	#
	my @array = sort {$a<=>$b} keys %$value;
	my $leastval = shift @array;
	my $code = $value->{$leastval};

}

=head2 line

Draw a line between 2 points

=cut

sub SVG::GD::Image::line($$$$$$) {
	my $self = shift;
	my ($x1,$y1,$x2,$y2,$colour) = @_;
#	$self->{_GD_}->line(@_);
	$self->{_SVG_}->line(x1=>$x1,x2=>$x2,y1=>$y1,y2=>$y2,
		stroke=>$self->getColour($colour));
}

sub SVG::GD::Image::dashedLine($$$$$$) {
	my $self = shift;
	my ($x1,$y1,$x2,$y2,$colour) = @_;
#	$self->{_GD_}->dashedLine(@_);
	$self->{_SVG_}->line(x1=>$x1,x2=>$x2,y1=>$y1,y2=>$y2,
		stroke=>$self->getColour($colour));
}

=head2 filledRectangle

Draw a filled rectangle.

=cut

sub SVG::GD::Image::filledRectangle($$$$$$$) {
	my $self = shift;
	my ($x1,$y1,$x2,$y2,$colour) = @_;
#	$self->{_GD_}->filledRectangle(@_);
	$self->{_SVG_}->rect(x=>$x1,y=>$y1,
			width=>$x2-$x1,height=>$y2-$y1,
			fill=>$self->getColour($colour),
			stroke=>$self->getColour($colour));
}

=head2 rectangle

Draw a rectangle.

=cut

sub SVG::GD::Image::rectangle($$$$$$$) {
	my $self = shift;
	my ($x1,$y1,$x2,$y2,$colour) = @_;
#	$self->{_GD_}->rectangle(@_);
	$self->{_SVG_}->rect(x=>$x1,y=>$y1,
			width=>$x2-$x1,height=>$y2-$y1,fill=>'none',
			stroke=>$self->getColour($colour));
}
=head2 arc

Draw an arc. Only supports closed arcs at present.
Note that we will ultimately need to differenciate between
an arc and a circle.

=cut

sub SVG::GD::Image::arc($$$$$$$$) {
	my $self = shift;
	my ($cx,$cy,$width,$height,$start,$end,$colour) = @_;
	$self->{_SVG_}->ellipse(cx=>$cx,cy=>$cy,
			rx=>$width/2,ry=>$height/2,fill=>'none',
			stroke=>$self->getColour($colour));
#	return $self->{_GD_}->arc(@_);
}

=head2  SVG::GD::Image::filledPolygon

Draw a polygon defined by ab SVG::GD::Polygon object

=cut

sub SVG::GD::Image::filledPolygon ($$$) {
	my $self = shift;
	my $poly = shift;
	my $fill = shift;

	my ($x,$y) = ([],[]);
	foreach my $set (@{$poly->{points}}) {
		my ($myx,$myy) = ($set->[0],$set->[1]);
		push @$x,$myx;
		push @$y,$myy;
	}
	my $points = $self->{_SVG_}->
	get_path(x=>$x, y=>$y,
		-type=>'path',
		-closed=>'true');
	$self->{_SVG_}->path(%$points,fill=>$self->getColour($fill));
}

=head2 polygon

Draw an empty polygon

=cut

sub SVG::GD::Image::polygon ($$$) {
	my $self = shift;
	my $poly = shift;
	my $stroke = shift;

	my ($x,$y) = ([],[]);
	foreach my $set (@{$poly->{points}}) {
		my ($myx,$myy) = ($set->[0],$set->[1]);
		push @$x,$myx;
		push @$y,$myy;
	}
	my $points = $self->{_SVG_}->
	get_path(x=>$x, y=>$y,
		-type=>'path',
		-closed=>'true');
	$self->{_SVG_}->path(%$points,stroke=>$self->getColour($stroke),fill=>'none');
}


#string methods

=head1 string methods

=head2 string

write a text string

=cut

sub SVG::GD::Image::string ($$$$$$) {
	my $self = shift;
	my ($myfont,$x,$y,$text,$colour) = @_;
#	$self->{_GD_}->string(@_);
	$self->{_SVG_}->text(
		'baseline-shift'=>'sub',
		style=>{
			SVG::GD::Font::getSVGstyle($myfont),
			fill=>$self->getColour($colour),
		},
		x=>$x,
		y=>$y)->tspan(dy=>'1em') ->cdata($text);
}

=head2 char

write a character

=cut

*SVG::GD::Image::char = \&SVG::GD::Image::string;

=head2 charUp

write a character upwards

=cut

sub SVG::GD::Image::stringUp ($$$$$$) {
    my $self = shift;
	my ($myfont,$x,$y,$text,$colour) = @_;
#	$self->{_GD_}->string(@_);
	$self->{_SVG_}->text(
		style=>{'writing-mode'=>'tb',
				SVG::GD::Font::getSVGstyle($myfont),
				fill=>$self->getColour($colour),
				},
		x=>$x,y=>$y,
		)->cdata($text);
}
*SVG::GD::Image::charUp = \&SVG::GD::Image::stringUp;

#---------------
#internal methods


sub SVG::GD::Image::getRGB($$) {
	my $self = shift;
	my $colour = shift;
	return $self->{_COLOUR_}->{$colour}->{rgb};
}

sub SVG::GD::Image::getColour($$) {
	my $self = shift;
	my $colour = shift;
	return $self->{_COLOUR_}->{$colour}->{svg};
}

=head2 rgb

Return the red,green,blue array for an allocated colour

=cut

sub SVG::GD::Image::rgb ($$) {
	my $self = shift;
	my $col = shift;
	return @{$self->getRBG($col)};
}

=head2 svg

replace the gif writing request with an svg writing request

=cut

sub SVG::GD::Image::svg ($) {
	my $self = shift;
	return $self->{_SVG_}->xmlify;
}

=head2 png

Return the binary image in PNG format

=cut

sub SVG::GD::Image::png ($) {
	my $self = shift;
	return $self->svg;
#	return $self->{_GD_}->png;
}

=head2 jpg

Return the binary image in JPEG format

=cut

sub SVG::GD::Image::wbmp ($$) {
	my $self = shift;
#	return $self->{_GD_}->wbmp(@_);
}

=head2 gif

Return the binary image in GIF format
Note that some versions of SVG::GD do not support this method

=cut

sub SVG::GD::Image::gif ($) {
	my $self = shift;
	return $self->svg;
}
#------------------
#ignored methods that are meaningless
#or too difficult to implement


sub SVG::GD::Image::interlaced ($) {
	my $self = shift;
#	$self->{_GD_}->interlaced(@_);
}

sub SVG::GD::Image::transparent ($$) {
	my $self = shift;
	my $colour = shift;
#	$self->{_GD_}->transparent($colour)
}

sub SVG::GD::Image::fill ($$$$) {
	my $self = shift;
	my ($x,$y,$colour) = @_;
#	$self->{_GD_}->fill(@_);
}

sub SVG::GD::Image::fillToBorder ($$$$) {
	my $self = shift;
	my ($x,$y,$colour) = @_;
#	$self->{_GD_}->fillToBorder(@_);
}

############################################################################
#
# new methods on GD::Image
#
############################################################################

sub SVG::GD::Image::polyline ($$$) {
    my $self = shift;   # the GD::Image
    my $p    = shift;   # the GD::Polyline (or GD::Polygon)
	my $c    = shift;   # the color

	my @points = $p->vertices();
	my $p1 = shift @points;
	my $p2;
	while ($p2 = shift @points) {
		$self->line(@$p1, @$p2, $c);
		$p1 = $p2;
	}
}

sub GD::Image::polydraw ($$$) {
	my $self = shift;   # the GD::Image
	my $p    = shift;   # the GD::Polyline or GD::Polygon
	my $c    = shift;
	# the color return
	$self->polyline($p, $c) if $p->isa('GD::Polyline');
	return $self->polygon($p, $c);
}

sub setBrush ($$) {
	my $self = shift;
	my $brush = shift;
	return "Sorry..Ignoring this command. Unable to setBrush with this version
	of SVG::GD";
}