File Coverage

blib/lib/Image/Base/SVGout.pm

Criterion	Covered	Total	%
statement	24	114	21.0
branch	4	56	7.1
condition	0	36	0.0
subroutine	8	21	38.1
pod	9	9	100.0
total	45	236	19.0

# Copyright 2011, 2012 Kevin Ryde

# This file is part of Image-Base-Other.
#
# Image-Base-Other 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-Other 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-Other.  If not, see .


package Image::Base::SVGout;
use 5.006;
use strict;
use Carp;
use vars '$VERSION', '@ISA';

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

$VERSION = 9;

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

sub new {
  my ($class, %params) = @_;

  if (ref $class) {
    my $self = $class;
    $class = ref $self;
    if ($self->{'-filehandle'}) {
      croak "Cannot clone SVGout after drawing begun";
    }
    %params = (%$self, %params);  # inherit
    ### copy params: \%params
  }

  if (defined $params{'-file'}) {
    croak "Cannot load initial -file, Image::Base::SVGout is output-only";
  }
  return bless \%params, $class;
}

sub DESTROY {
  my ($self) = @_;
  if ($self->{'-filehandle'}) {
    $self->save;  # closing
  }
}

sub set {
  my ($self, %param) = @_;
  if ($self->{'-filehandle'}) {
    foreach my $key ('-file', '-title', '-description') {
      if (exists $param{$key}) {
        _nochange_str ($self, $key, $param{$key});
      }
    }
    foreach my $key ('-width', '-height') {
      if (exists $param{$key}) {
        _nochange_str ($self, $key, $param{$key});
      }
    }
  }
  %$self = (%$self, %param);
}
sub _nochange_str {
  my ($self, $key, $newval) = @_;
  if (defined $self->{$key}
      && (! defined $newval
          || $newval ne $self->{$key})) {
    croak "Cannot change $key after output has begun";
  }
}
sub _nochange_num {
  my ($self, $key, $newval) = @_;
  if (defined $self->{$key}
      && (! defined $newval
          || $newval != $self->{$key})) {
    croak "Cannot change $key after output has begun";
  }
}

sub _out {
  my $self = shift;
  my $fh = $self->{'-filehandle'} || _start_out($self);
  print $fh @_, "\n"
    or croak "Error writing $self->{'-file'}: $!";
}



  # require Fcntl;
  # sysopen FH, $filename, Fcntl::O_WRONLY() | Fcntl::O_TRUNC() | Fcntl::O_CREAT()
  #   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: $!";

sub _start_out {
  my ($self) = @_;

  if ($self->{'save_done'}) {
    croak "Cannot draw more after save()";
  }

  my $filename = $self->{'-file'};
  if (! defined $filename) {
    croak "No -file set";
  }

  my $width = $self->{'-width'};
  my $height = $self->{'-height'};
  if (! defined $width || ! defined $height) {
    croak "No -width / -height set";
  }

  my $class = ref $self;
  my $version = $self->VERSION;

  foreach ($width,$height,$class,$version) {
    $_ = _entitize($_);
  }

  my ($title, $description);
  open my $fh, '>', $filename
    or croak "Cannot write file $filename: $!";

  print $fh <<"HERE",




HERE

    (defined ($title = $self->{'-title'})
     ? ("", _entitize($title), "\n")
     : ()),

       (defined ($description = $self->{'-description'})
        ? ("", _entitize($self->{'-description'}), "")
        : ())

         or croak "Error writing $filename: $!";

  return ($self->{'-filehandle'} = $fh);
}

sub _close_out {
  my ($self) = @_;

  if (my $fh = delete $self->{'-filehandle'}) {
    close $fh or croak "Error closing $self->{'-file'}: $!";
  }
}

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

  _out ($self, "");
  $self->{'save_done'} = 1;
  _close_out ($self);
}

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

  if (@_ == 3) {
    return undef;  # no fetch
  } else {
    _out ($self,
          '
194
          '" y="', $y,
          '" width="1" height="1" fill="', _entitize($colour), '"/>');
  }
}

sub rectangle {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Image-Base-SVGout 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;
  }
  _out ($self,
        '
212
        '" y="', $y1,
        '" width="',  $x2-$x1+1,
        '" height="', $y2-$y1+1, '" ',
        ($fill?'fill':'stroke'), '="', _entitize($colour),
        '"/>');
}

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

  $fill ||= ($x1 == $x2 || $y1 == $y2);  # 1xN or Nx1 done filled
  my $rx = ($x2-$x1+1) / 2;
  my $ry = ($y2-$y1+1) / 2;
  if (! $fill) {
    $rx -= .5;  # for stroke width 1
    $ry -= .5;
  }
  _out ($self,
        '
232
        '" cy="', (($y1+$y2+1) / 2),
        '" rx="', $rx,
        '" ry="', $ry,'" ',
        ($fill?'fill':'stroke'),'="', _entitize($colour), '"/>');
}

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

  _out ($self,
        '
244
        '" y1="', $y1+.5,
        '" x2="', $x2+.5,
        '" y2="', $y2+.5,
        '" stroke="', _entitize($colour),
        '" stroke-linecap="square"/>');
}

sub diamond {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Image-Base-SVGout 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;
  _out ($self,
        '
269
        $xm,',',$y1,' ',
        $x1,',',$ym,' ',
        $xm,',',$y2,' ',
        $x2,',',$ym,'" ',
        ($fill?'fill':'stroke'),'="', _entitize($colour), '"/>');
}

sub load {
  my ($self, $filename) = @_;
  croak "Image::Base::SVGout is output-only";
}

# Could leave wide chars as utf8 bytes, and latin1 bytes upgraded, if apply
# the right layers to the open and in new enough perl.  For now send all
# non-ascii-printable to numbered.
#
my %entity = ('&' => '&',
              '"' => '"',
              '<' => '<',
              '>' => '>',
             );
sub _entitize {
  my ($value) = @_;
  $value =~ s{([&"<>]|[^\t\r\n\x20-\x7F])}
             { $entity{$1} || ('&#'.ord($1).';') }eg;
  return $value;
}

1;
__END__