File Coverage

lib/Postscript/HTML/Map.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package Postscript::HTML::Map;

# Assumes bounding box

use strict;
use warnings;

use base qw/Class::Accessor::Fast/;

use Data::Dumper;
use HTML::Element;
use Math::Bezier;

__PACKAGE__->mk_accessors(qw/postscript map width height current_x current_y args_stack polygon
                             comments html_handler scale_x scale_y/);

our $VERSION = '1.0001';

my %handlers = (
    BeginEPSF   => undef,
    stroke      => undef,
    arc         => 'add_arc',
    newpath     => 'create_newpath',
    moveto      => 'perform_move',
    lineto      => 'add_line',
    curveto     => 'add_curve',
    closepath   => 'perform_closepath', # Will need to do more later
    scale       => 'adjust_scaling', # Will need to do more later
    );
my $handler_regex = join '|', keys %handlers;

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

    unless ($self->postscript){
        print STDERR "No postscript provided\n";
        return 0;
        }

    unless (-r $self->postscript){
        printf STDERR "Postscript file %s not readable\n", $self->postscript;
        return 0;
        }

    # Ensure we have fresh html output
    $self->map(HTML::Element->new(
        'map'
        ));

    my @postscript;
    do {
        open(my $ps_file, "<".$self->postscript);
        chomp(@postscript = <$ps_file>);
        close $ps_file;

        # Find the Comment that states the bounding box.
        # Working this out from the postscript would be extremely difficult,
        # Due to needing to process all the curves first.
        my ($bounding_definition) = map {
            /^%.*BoundingBox:\s*((?:\d+\s*){4})/ ? $1 : ()
            } @postscript;
        my (undef, undef, $width, $height) = split /\s+/, $bounding_definition;
        $self->width($width);
        $self->height($height);
        };

    $self->current_coords(0, 0);
    $self->args_stack([]);
    $self->polygon([]);
    $self->comments([]);
    $self->scale(1,1);

    while (@postscript){
        if ($postscript[0] =~ /^\s*%/){
            # A comment
            my ($comment) = (shift @postscript) =~ /^\s*%+(.*)/;

            $self->comment($comment);

            next;
            }
        unless ($postscript[0] =~ s#^\s*(.*?)\s*($handler_regex)##){
            # Nothing left on this line that interests us
            shift @postscript;
            next;
            }
        my ($args, $cmd) = ($1,$2);

        my $method_name = $handlers{$cmd};
        next unless $method_name;

        my $method = $self->can($method_name);
        next unless $method;
        $self->$method($cmd, $args);
        }

    return $self->map;
    }

sub add_arc {
    my ($self, $cmd, $args) = @_;

    my ($x, $y, $radius, $start_angle, $end_angle) = split / +/, $args;
    if (($start_angle == 0   && $end_angle == 360) ||
        ($start_angle == 360 && $end_angle == 0)){
        # Complete circle, use the circle operator

        $x *= $self->scale_x;
        $y *= $self->scale_y;

        # Radius handling goes crazy if scaling isn't equal, so we assume x
        $radius *= $self->scale_x;

        my $element = HTML::Element->new('area',
            shape   => 'circle',
            coords  => join(', ', map $_.'px', $x, $self->height - $y, $radius),
            );

        if (ref $self->html_handler){
            $self->html_handler->($self, $element);
            }

        $self->map->push_content($element);
        }

    return $self;
    }

sub create_newpath {
    my ($self, $cmd, $args) = @_;

    if ($args){
        # Sometimes we get arguments to this, but they're really intended for the next command
        $self->args_stack_push($args);
        }

    $self->polygon([]);

    return;
    }

sub perform_move {
    my ($self, $cmd, $args) = @_;

    if (!$args){
        # Perhaps there's something in the stack for us?
        $args = $self->args_stack_pop;
        }

    die "moveto without args" unless $args;

    my ($x, $y) = split /\s+/, $args;

    $x *= $self->scale_x;
    $y *= $self->scale_y;

    $self->current_coords($x, $y);

    return;
    }

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

    if (@{$self->polygon}){

        $self->map->push_content(['area', {
            shape   => 'poly',
            coords  => join(", ", map $_.'px', @{$self->polygon}),
            href    => 'javascript:alert("'.$self->comment.'");',
            }]);

        $self->polygon([]);
        }

    return;
    }

sub add_curve {
    my ($self, $cmd, $args) = @_;

    die "No args to curveto" unless $args;

    # Bezier Curve
    my ($control1_x, $control1_y,
        $control2_x, $control2_y,
        $end_x, $end_y) = split /\s+/, $args;

    $control1_x *= $self->scale_x;
    $control1_y *= $self->scale_y;
    $control2_x *= $self->scale_x;
    $control2_y *= $self->scale_y;
    $end_x *= $self->scale_x;
    $end_y *= $self->scale_y;

    my $bezier = Math::Bezier->new(
        $self->current_coords,
        $control1_x, $control1_y,
        $control2_x, $control2_y,
        $end_x, $end_y
        );

    $self->add_to_polygon(
        $bezier->curve(20)
        );

    $self->current_coords($end_x, $end_y);

    return;
    }

sub add_line {
    my ($self, $cmd, $args) = @_;

    die "No co-ordinates for line" unless $args;

    # Firstly, generate the line in the polygon
    $self->add_to_polygon($self->current_coords);

    my ($x, $y) = split /\s+/, $args;

    $x *= $self->scale_x;
    $y *= $self->scale_y;

    $self->add_to_polygon($x, $y);

    $self->current_coords($x, $y);

    return;
    }

sub adjust_scaling {
    my ($self, $cmd, $args) = @_;

    die "No scaling provided" unless $args;

    my ($x, $y) = split /\s+/, $args;

    $self->scale($x, $y);

    $self->height( $self->height * $self->scale_y );
    $self->width( $self->width * $self->scale_x );

    return;
    }

sub current_coords {
    my ($self, $x, $y) = @_;

    if ($x && $y){
        $self->current_x($x);
        $self->current_y($y);
        }

    return ($self->current_x, $self->current_y);
    }

sub args_stack_push {
    my ($self, $args) = @_;

    push @{$self->args_stack}, $args;

    return;
    }

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

    return pop @{$self->args_stack};
    }

sub add_to_polygon {
    my ($self, @coords) = @_;

    die "Uneven number of co-ordinates adding to polygon" if scalar(@coords) % 2;

    push @{$self->polygon}, @coords;

    return;
    }

sub comment {
    my ($self, $comment) = @_;

    if ($comment){
        push @{$self->comments}, $comment;
        }

    return $self->comments->[-1];
    }

sub scale {
    my ($self, $x, $y) = @_;

    if ($x && $y){
        $self->scale_x($x);
        $self->scale_y($y);
        }

    return ($self->scale_x, $self->scale_y);
    }

1;

__END__