File Coverage

blib/lib/Perl/Visualize.pm

Criterion	Covered	Total	%
statement	9	57	15.7
branch	0	12	0.0
condition			n/a
subroutine	3	11	27.2
pod	0	8	0.0
total	12	88	13.6

package Perl::Visualize;

use 5.008;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw( etch paint );

our $VERSION = '1.02';

sub readgif {
  my($io, $chrs) = @_;
  read($io, my $result, $chrs) == $chrs or die "premature end of file: $io\n";
  return $result;
}

sub parsegif {
  my($in) = @_;
  open my $io, "<$in" or die "failed to parse input file, $in: $@\n";
  my $header = readgif($io, 3);
  $header eq "GIF" or die "input file is not a GIF\n";

  my $version = readgif($io,3);
  my $width = readgif($io,2);
  my $height = readgif($io,2);
  my $colordesc = readgif($io,1);
  my($num_of_colors) = ord($colordesc) & 0b10000000
                     ? (1 << ((ord($colordesc) & 0b00000111) + 1)) * 3
		     : 0;
  my $bkground = readgif($io, 2);
  my $colortable = readgif($io,$num_of_colors);

  local undef $/;  my $remainder = <$io>;
  close $io;
  return ($width, $height, $colordesc, $bkground, $colortable, $remainder);
}

sub gifcomment {
  my($code) = join '', @_;
  my($index) = 1 + ord substr $code, 0, 1;
  while ( $index < length $code ) {
    $index += 1 + ord substr $code, $index, 1;
  }
  $code .= " " x ($index - length $code);
  $code .= "\x04    \x00";
  return $code;
}

sub perlcomment {
  my($comment) = @_;
  $comment =~ s/\x0a/\x0b/g;
  return "# $comment";
}

sub perlstring {
  my($string) = @_;
  $string =~ s/\xfe/\xfd/g;
  return "q\xfe$string\xfe";
}

sub deparsegif {
  my($outputfile, $colordesc, $bkground, $colortable, $remainder, $escape, $perl) = @_;
  open my $io, ">$outputfile" or die "failed to open output file: $@\n";
  $colortable =~ s/\xfe/\xfd/g;
  print $io "GIF89a;";
  if ( $escape eq "comment" ) {
    print $io perlcomment ";$colordesc$bkground$colortable\x21\xfe";
    print $io gifcomment "\n$perl" # Comments terminated by EOL
  } else {
    print $io perlstring ";$colordesc$bkground$colortable\x21";
    print $io gifcomment ";$perl"  # String statement terminated by semicolon
  }
  print $io $remainder;
  close $io;
}

sub etch {
  my($imagefile, $outputfile, $perl) = @_;
  my($width, $height, $colordesc, $bkground, $colortable, $remainder) = parsegif($imagefile);
  deparsegif ( $outputfile, $colordesc, $bkground, $colortable, $remainder, "comment", $perl );
}

sub paint {
  my($imagefile, $outputfile, $perl) = @_;
  my($width, $height, $colordesc, $bkground, $colortable, $remainder) = parsegif($imagefile);
  deparsegif ( $outputfile, $colordesc, $bkground, $colortable, $remainder, "string", $perl );
}

1;
__END__