File Coverage

blib/lib/Image/Base/SVG.pm

Criterion	Covered	Total	%
statement	107	119	89.9
branch	36	46	78.2
condition	18	23	78.2
subroutine	21	21	100.0
pod	9	10	90.0
total	191	219	87.2

# Copyright 2011 Kevin Ryde

# This file is part of Image-Base-SVG.
#
# Image-Base-SVG is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Image-Base-SVG is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Image-Base-SVG.  If not, see .


package Image::Base::SVG;
use 5.006;  # SVG is 5.6 for weakening
use strict;
use Carp;
use SVG; # version 2.50 needs an import() to create methods

use vars '$VERSION', '@ISA';
$VERSION = 4;

use Image::Base;
@ISA = ('Image::Base');

# uncomment this to run the ### lines
#use Devel::Comments '###';


sub new {
  my ($class, %params) = @_;
  ### Image-Base-SVG new(): %params

  # $obj->new(...) means make a copy, with some extra settings
  if (ref $class) {
    my $self = $class;
    $class = ref $self;
    croak "Cannot clone $class yet ..."

    # if (! defined $params{'-svg_object'}) {
    #   $params{'-svg_object'} = $self->{'-svg_object'}->cloneNode;
    # }
    # # inherit everything else
    # %params = (%$self, %params);
    # ### copy params: \%params
  }

  my $svg = delete $params{'-svg_object'};
  if (! $svg) {
    $svg = SVG->new ((exists $params{'-width'}
                      ? (width => delete $params{'-width'})
                      : ()),
                     (exists $params{'-height'} ?
                      (height => delete $params{'-height'})
                      : ()));
  }

  my $self = bless { -svg_object => $svg }, $class;
  ### %params
  $self->set (%params);
  return $self;
}

# these two not documented yet
my %key_to_cdata = ('-title'       => 'title',
                    '-description' => 'desc');

my %key_to_attribute = ('-width'  => 'width',
                        '-height' => 'height');
sub _get {
  my ($self, $key) = @_;
  ### _get(): $key

  if (my $tagname = $key_to_cdata{$key}) {
    my $elem;
    return (($elem = _get_tag($self,$tagname))
            && $elem->getCDATA);

  } elsif (my $aname = $key_to_attribute{$key}) {
    return _svg_element($self)->getAttribute ($aname);

  } else {
    return $self->{$key};
  }
}

sub set {
  my $self = shift;
  while (@_) {
    my $key = shift;
    @_ or croak "Odd number of arguments to set()";
    my $value = shift;

    if (my $tagname = $key_to_cdata{$key}) {
      my $elem = _get_or_create_tag($self,$tagname);
      $elem->cdata ($value);

    } elsif (my $aname = $key_to_attribute{$key}) {
      ### $aname
      ### $value
      _svg_element($self)->setAttribute ($aname, $value);

    } else {
      $self->{$key} = $value;
    }
  }
}
sub _get_tag {
  my ($self,$tagname) = @_;
  my $svg = $self->{'-svg_object'};
  return ($svg->getElements($tagname))[0];
}
sub _get_or_create_tag {
  my ($self,$tagname) = @_;
  my $svg = $self->{'-svg_object'};
  my @elems = $svg->getElements($tagname);
  if (@elems) {
    return $elems[0];
  } else {
    return $svg->tag($tagname);
  }
}
sub _svg_element {
  my ($self) = @_;
  my $svg = $self->{'-svg_object'};
  ### docroot: $svg->{'-docroot'}
  ### elems: join(',',$svg->getElements())

  return ($svg->getElements($svg->{'-docroot'}))[0]
    || die "Oops, -docroot element not found";
}

sub xy {
  my ($self, $x, $y, $colour) = @_;
  ### Image-Base-SVG xy(): @_[1 .. $#_]

  my $svg = $self->{'-svg_object'};
  if (@_ == 3) {
    return undef;  # no pixel fetching available
  } else {
    $svg->rectangle (x => $x, y => $y,
                     width => 1, height => 1,
                     fill => $colour);
  }
}

sub rectangle {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Image-Base-SVG rectangle(): @_[1 .. $#_]

  $fill ||= ($x1 == $x2 || $y1 == $y2);  # 1xN or Nx1 done filled
  if (! $fill) {
    $x1 += .5;  # for stroke width 1
    $y1 += .5;
    $x2 -= .5;
    $y2 -= .5;
  }
  $self->{'-svg_object'}->rectangle (x => $x1,
                                     y => $y1,
                                     width  => $x2-$x1+1,
                                     height => $y2-$y1+1,
                                     ($fill?'fill':'stroke') => $colour);
}

sub ellipse {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Image-Base-SVG ellipse(): @_[1 .. $#_]

  $fill ||= ($x1 == $x2 || $y1 == $y2);
  my $rx = ($x2-$x1+1) / 2;
  my $ry = ($y2-$y1+1) / 2;
  if (! $fill) {
    $rx -= .5;  # for stroke width 1
    $ry -= .5;
  }
  $self->{'-svg_object'}->ellipse (cx => ($x1+$x2+1) / 2,
                                   cy => ($y1+$y2+1) / 2,
                                   rx => $rx,
                                   ry => $ry,
                                   ($fill?'fill':'stroke') => $colour);
}

sub line {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Image-Base-SVG rectangle(): @_[1 .. $#_]

  $self->{'-svg_object'}->line (x1 => $x1+.5,
                                y1 => $y1+.5,
                                x2 => $x2+.5,
                                y2 => $y2+.5,
                                stroke => $colour,
                                'stroke-linecap' => "square");
}

sub diamond {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Image-Base-SVG diamond(): @_[1 .. $#_]

  $fill ||= ($x1 == $x2 || $y1 == $y2);  # 1xN or Nx1 done filled
  if ($fill) {
    $x2++;
    $y2++;
  } else {
    $x1 += .5;  # for stroke width 1
    $y1 += .5;
    $x2 += .5;
    $y2 += .5;
  }
  my $xm = ($x1+$x2)/2;
  my $ym = ($y1+$y2)/2;
  $self->{'-svg_object'}->polygon (points => "$xm,$y1 $x1,$ym $xm,$y2 $x2,$ym",
                                   ($fill?'fill':'stroke') => $colour);
}

sub load {
  my ($self, $filename) = @_;
  if (@_ > 1) {
    $self->set('-file', $filename);
  } else {
    $filename = $self->get('-file');
  }
  ### $filename

  # stringize any oopery to stop SVG::Parser being clever ... maybe
  $filename = "$filename";

  # use SVG::Parser qw(SVG::Parser::SAX=XML::LibXML::SAX::Parser);
  # use SVG::Parser qw(SVG::Parser::SAX=XML::LibXML::SAX::Parser);

  eval 'use SVG::Parser; 1' or die;
  my $parser = SVG::Parser->new (
                                 # -debug => 1,
                                );
  my $svg = $parser->parse_file ($filename);
  $self->{'-svg_object'} = $svg;
}

sub save {
  my ($self, $filename) = @_;
  ### Image-Base-SVG save(): @_
  if (@_ > 1) {
    $self->set('-file', $filename);
  } else {
    $filename = $self->get('-file');
  }
  ### $filename

  open my $fh, '>', $filename,
    or croak "Cannot create $filename: $!";

  if (! $self->save_fh ($fh)) {
    my $err = "Error writing $filename: $!";
    { local $!; close $fh; }
    croak $err;
  }
  close $fh
    or croak "Error closing $filename: $!";
}

# not yet documented ...
sub save_fh {
  my ($self, $fh) = @_;
  ### save_fh() ...
  ### elements: $self->{'-elements'}
  ### height: $self->{'-height'}

  my $svg = $self->{'-svg_object'};
  # $svg->comment ("\n\tGenerated using ".ref($self)." version ".$self->VERSION."\n");
  return print $fh $svg->xmlify;
}

# sub _add_comment {
#   my ($self) = @_;
#   my $svg_element = _svg_element($self);
#   my $generated
#     = "\n\tGenerated using ".ref($self)." version ".$self->VERSION."\n";
#   foreach my $comment ($svg_element->getElements('comment')) {
#     if ($comment->cdata eq $generated) {
#       return;
#     }
#   }
#   $self->{'-svg_object'}->comment ($generated);
# }

1;
__END__