File Coverage

blib/lib/SVG/Element.pm

Criterion	Covered	Total	%
statement	206	315	65.4
branch	89	148	60.1
condition	13	37	35.1
subroutine	28	41	68.2
pod	1	33	3.0
total	337	574	58.7

package SVG::Element;

use strict;
use warnings;

our $VERSION = '2.86';

=pod

=encoding UTF-8

=head1 NAME

SVG::Element - Generate the element bits for SVG.pm

=head1 AUTHOR

Ronan Oger, [e-mail]

=head1 SEE ALSO

For descreption of the methods see L

L ROASP.com: Serverside SVG server
L ROIT Systems: Commercial SVG perl solutions
L SVG at the W3C

=cut

use SVG::XML;
use SVG::DOM;
use SVG::Extension;
use Scalar::Util qw/weaken/;

our $AUTOLOAD;

my @autosubs = qw(
    animateMotion animateColor animateTransform circle ellipse rect polyline
    path polygon line title desc defs
    altGlyph altGlyphDef altGlyphItem clipPath color-profile
    cursor definition-src font-face-format font-face-name
    font-face-src font-face-url foreignObject glyph
    glyphRef hkern marker mask metadata missing-glyph
    mpath switch symbol textPath tref tspan view vkern marker textbox
    flowText style script
    image a g
);

our %autosubs = map { $_ => 1 } @autosubs;

#-------------------------------------------------------------------------------

sub new {
    my ( $proto, $name, %attrs ) = @_;
    my $class = ref($proto) || $proto;
    my $self  = { -name => $name };
    foreach my $key ( keys %attrs ) {

        #handle escapes for special elements such as anchor
        if ( $key =~ /^-/ ) {
            if ( $key eq '-href' ) {
                $self->{'xlink:href'}    = $attrs{$key};
                $self->{'xlink:type'}    = $attrs{-type} if $attrs{-type};
                $self->{'xlink:role'}    = $attrs{-role} if $attrs{-role};
                $self->{'xlink:title'}   = $attrs{-title} if $attrs{-title};
                $self->{'xlink:show'}    = $attrs{-show} if $attrs{-show};
                $self->{'xlink:arcrole'} = $attrs{-arcrole}
                    if $attrs{-arcrole};
                $self->{'xlink:actuate'} = $attrs{-actuate}
                    if $attrs{-actuate};
                next;
            }
        }
        $self->{$key} = $attrs{$key};
    }

    return bless( $self, $class );
}

#-------------------------------------------------------------------------------

sub release {
    my $self = shift;

    foreach my $key ( keys( %{$self} ) ) {
        next if $key =~ /^-/;
        if ( ref( $self->{$key} ) =~ /^SVG/ ) {
            eval { $self->{$key}->release; };
        }
        delete( $self->{$key} );
    }

    return $self;
}

sub xmlify {
    my $self = shift;
    my $ns   = $self->{-namespace} || $self->{-docref}->{-namespace} || undef;
    my $xml  = '';

    #prep the attributes
    my %attrs;
    foreach my $k ( keys( %{$self} ) ) {
        if ( $k =~ /^-/ ) { next; }
        if ( ref( $self->{$k} ) eq 'ARRAY' ) {
            $attrs{$k} = join( ', ', @{ $self->{$k} } );
        }
        elsif ( ref( $self->{$k} ) eq 'HASH' ) {
            $attrs{$k} = cssstyle( %{ $self->{$k} } );
        }
        elsif ( ref( $self->{$k} ) eq '' ) {
            $attrs{$k} = $self->{$k};
        }
    }

    #prep the tag
    if ( $self->{-comment} ) {
        $xml .= $self->xmlcomment( $self->{-comment} );
        return $xml;
    }
    elsif ( $self->{-name} eq 'document' ) {

        #write the xml header
        $xml .= $self->xmldecl unless $self->{-inline};

        $xml .= $self->xmlpi( $self->{-document}->{-pi} )
            if $self->{-document}->{-pi};

        #and write the dtd if this is inline
        $xml .= $self->dtddecl unless $self->{-inline};

        #rest of the xml
        foreach my $k ( @{ $self->{-childs} } ) {
            if ( ref($k) =~ /^SVG::Element/ ) {
                $xml .= $k->xmlify($ns);
            }
        }

        return $xml;
    }
    my $is_cdataish
        = defined $self->{-cdata}
        || defined $self->{-CDATA}
        || defined $self->{-cdata_noxmlesc};
    if ( defined $self->{-childs} || $is_cdataish ) {
        $xml .= $self->{-docref}->{-elsep}
            unless ( $self->{-inline} && $self->{-name} );
        $xml .= $self->{-docref}->{-indent} x $self->{-docref}->{-level};
        $xml .= xmltagopen_ln( $self->{-name}, $ns, %attrs );
        $self->{-docref}->{-level}++;
        foreach my $k ( @{ $self->{-childs} } ) {
            if ( ref($k) =~ /^SVG::Element/ ) {
                $xml .= $k->xmlify($ns);
            }
        }

        if ( defined $self->{-cdata} ) {
            $xml .= $self->xmlescp( $self->{-cdata} );
        }
        if ( defined $self->{-CDATA} ) {
            $xml .= '{-CDATA} . ']]>';
        }
        if ( defined $self->{-cdata_noxmlesc} ) {
            $xml .= $self->{-cdata_noxmlesc};
        }

        #return without writing the tag out if it the document tag
        $self->{-docref}->{-level}--;
        unless ($is_cdataish) {
            $xml .= $self->{-docref}->{-elsep};
            $xml .= $self->{-docref}->{-indent} x $self->{-docref}->{-level};
        }
        $xml .= xmltagclose_ln( $self->{-name}, $ns );
    }
    else {
        $xml .= $self->{-docref}->{-elsep};
        $xml .= $self->{-docref}->{-indent} x $self->{-docref}->{-level};
        $xml .= xmltag_ln( $self->{-name}, $ns, %attrs );
    }

    #return the finished tag
    return $xml;
}

sub perlify {
    my $self = shift;
    my $code = '';

    #prep the attributes
    my %attrs;
    foreach my $k ( keys( %{$self} ) ) {
        next if $k =~ /^-/;
        if ( ref( $self->{$k} ) eq 'ARRAY' ) {
            $attrs{$k} = join( ', ', @{ $self->{$k} } );
        }
        elsif ( ref( $self->{$k} ) eq 'HASH' ) {
            $attrs{$k} = cssstyle( %{ $self->{$k} } );
        }
        elsif ( ref( $self->{$k} ) eq '' ) {
            $attrs{$k} = $self->{$k};
        }
    }

    if ( $self->{-comment} ) {
        $code .= "->comment($self->{-comment})";
        return $code;
    }
    elsif ( $self->{-pi} ) {
        $code .= "->pi($self->{-pi})";
        return $code;
    }
    elsif ( $self->{-name} eq 'document' ) {

        #write the xml header
        #$xml .= $self->xmldecl;
        #and write the dtd if this is inline
        #$xml .= $self->dtddecl unless $self->{-inline};
        foreach my $k ( @{ $self->{-childs} } ) {
            if ( ref($k) =~ /^SVG::Element/ ) {
                $code .= $k->perlify();
            }
        }
        return $code;
    }

    if ( defined $self->{-childs} ) {
        $code .= $self->{-docref}->{-elsep};
        $code .= $self->{-docref}->{-indent} x $self->{-docref}->{-level};
        $code
            .= $self->{-name} . '('
            . ( join ', ', ( map {"$_=>'$attrs{$_}'"} sort keys %attrs ) )
            . ')';
        if ( $self->{-cdata} ) {
            $code .= "->cdata($self->{-cdata})";
        }
        elsif ( $self->{-CDATA} ) {
            $code .= "->CDATA($self->{-CDATA})";
        }
        elsif ( $self->{-cdata_noxmlesc} ) {
            $code .= "->cdata_noxmlesc($self->{-cdata_noxmlesc})";
        }

        $self->{-docref}->{-level}++;
        foreach my $k ( @{ $self->{-childs} } ) {
            if ( ref($k) =~ /^SVG::Element/ ) {
                $code .= $k->perlify();
            }
        }
        $self->{-docref}->{-level}--;
    }
    else {
        $code .= $self->{-docref}->{-elsep};
        $code .= $self->{-docref}->{-indent} x $self->{-docref}->{-level};
        $code
            .= $self->{-name} . '('
            . ( join ', ', ( map {"$_=>'$attrs{$_}'"} sort keys %attrs ) )
            . ')';
    }

    return $code;
}
*toperl = \&perlify;

sub addchilds {
    my $self = shift;
    push @{ $self->{-childs} }, @_;
    return $self;
}

sub tag {
    my ( $self, $name, %attrs ) = @_;

    unless ( $self->{-parent} ) {

        #traverse down the tree until you find a non-document entry
        while ( $self->{-document} ) { $self = $self->{-document} }
    }
    my $tag = new SVG::Element( $name, %attrs );

    #define the element namespace
    $tag->{-namespace} = $attrs{-namespace} if ( $attrs{-namespace} );

    #add the tag to the document element
    $tag->{-docref} = $self->{-docref};
    weaken( $tag->{-docref} );

    #create the empty idlist hash ref unless it already exists
    $tag->{-docref}->{-idlist} = {}
        unless ( defined $tag->{-docref}->{-idlist} );

    #verify that the current id is unique. compain on exception
    #>>>TBD: add -strictids option to disable this check if desired
    if ( $tag->{id} ) {
        if ( $self->getElementByID( $tag->{id} ) ) {
            $self->error( $tag->{id} => 'ID already exists in document' );
            return;
        }
    }

    #add the current id reference to the document id hash
    if ( defined( $tag->{id} ) ) {
        $tag->{-docref}->{-idlist}->{ $tag->{id} } = $tag;
    }

    #create the empty idlist hash ref unless it already exists
    $tag->{-docref}->{-elist} = {}
        unless ( defined $tag->{-docref}->{-elist} );

    #create the empty idlist hash ref unless it already exists
    $tag->{-docref}->{-elist}->{ $tag->{-name} } = []
        unless ( defined $tag->{-docref}->{-elist}->{ $tag->{-name} } );

#add the current element ref to the corresponding element-hash array
# -elist is a hash of element names. key name is element, content is object ref.

    # add the reference to $tag to the array of refs that belong to the
    # key $tag->{-name}.
    unshift @{ $tag->{-docref}->{-elist}->{ $tag->{-name} } }, $tag;

    # attach element to the DOM of the document
    $tag->{-parent} = $self;
    weaken( $tag->{-parent} );
    $tag->{-parentname} = $self->{-name};
    $self->addchilds($tag);

    return ($tag);
}

*element = \&tag;

sub anchor {
    my ( $self, %attrs ) = @_;
    my $an = $self->tag( 'a', %attrs );

    #$an->{'xlink:href'}=$attrs{-href} if(defined $attrs{-href});
    #$an->{'target'}=$attrs{-target} if(defined $attrs{-target});
    return ($an);
}

sub svg {
    my ( $self, %attrs ) = @_;
    my $svg = $self->tag( 'svg', %attrs );
    $svg->{'height'} = '100%' unless ( $svg->{'height'} );
    $svg->{'width'}  = '100%' unless ( $svg->{'width'} );
    return ($svg);
}

sub rectangle {
    my ( $self, %attrs ) = @_;
    return $self->tag( 'rect', %attrs );
}

#sub image {
#    my ($self,%attrs)=@_;
#    my $im=$self->tag('image',%attrs);
#    #$im->{'xlink:href'}=$attrs{-href} if(defined $attrs{-href});
#    return $im;
#}

sub use {
    my ( $self, %attrs ) = @_;
    my $u = $self->tag( 'use', %attrs );
    $u->{'xlink:href'} = $attrs{-href} if ( defined $attrs{-href} );
    return $u;
}

sub text {
    my ( $self, %attrs ) = @_;
    my $pre = '';
    $pre = $attrs{-type} || 'std';
    my %get_pre = (
        std  => 'text',
        path => 'textPath',
        span => 'tspan',
    );

    $pre = $get_pre{ lc($pre) };
    my $text = $self->tag( $pre, %attrs );
    $text->{'xlink:href'} = $attrs{-href}   if ( defined $attrs{-href} );
    $text->{'target'}     = $attrs{-target} if ( defined $attrs{-target} );
    return ($text);
}

sub comment {
    my ( $self, @text ) = @_;
    my $tag = $self->tag('comment');
    $tag->{-comment} = [@text];
    return $tag;
}

sub pi {
    my ( $self, @text ) = @_;
    return $self->{-document}->{-pi} unless scalar @text;
    my @pi;
    @pi = @{ $self->{-document}->{-pi} } if $self->{-document}->{-pi};
    unshift( @text, @pi ) if @pi;
    $self->{-document}->{-pi} = \@text;
    my $tag = $self->tag('pi');
    return $tag;
}

=pod

=head2 get_path

Documented as L.

=cut

sub get_path {
    my ( $self, %attrs ) = @_;

    my $type = $attrs{-type} || 'path';
    my @x    = @{ $attrs{x} };
    my @y    = @{ $attrs{y} };
    my $points;

    # we need a path-like point string returned
    if ( lc($type) eq 'path' ) {
        my $char = 'M';
        $char = ' m '
            if ( defined $attrs{-relative} && lc( $attrs{-relative} ) );
        while (@x) {

            #scale each value
            my $x = shift @x;
            my $y = shift @y;

            #append the scaled value to the graph
            $points .= "$char $x $y ";
            $char = ' L ';
            $char = ' l '
                if ( defined $attrs{-relative}
                && lc( $attrs{-relative} ) );
        }
        $points .= ' z '
            if ( defined $attrs{-closed} && lc( $attrs{-closed} ) );
        my %out = ( d => $points );
        return \%out;
    }
    elsif ( lc($type) =~ /^poly/ ) {
        while (@x) {

            #scale each value
            my $x = shift @x;
            my $y = shift @y;

            #append the scaled value to the graph
            $points .= "$x,$y ";
        }
    }
    my %out = ( points => $points );
    return \%out;
}

sub make_path {
    my ( $self, %attrs ) = @_;
    return get_path(%attrs);
}

sub set_path {
    my ( $self, %attrs ) = @_;
    return get_path(%attrs);
}

sub animate {
    my ( $self, %attrs ) = @_;
    my %rtr    = %attrs;
    my $method = $rtr{'-method'};    # Set | Transform | Motion | Color

    $method = lc($method);

    # we do not want this to pollute the generation of the tag
    delete $rtr{-method};            #bug report from briac.

    my %animation_method = (
        transform => 'animateTransform',
        motion    => 'animateMotion',
        color     => 'animateColor',
        set       => 'set',
        attribute => 'animate',
    );

    my $name = $animation_method{$method} || 'animate';

    #list of legal entities for each of the 5 methods of animations
    my %legal = (
        animate => q{ begin dur  end  min  max  restart  repeatCount
              repeatDur  fill  attributeType attributeName additive
              accumulate calcMode  values  keyTimes  keySplines
              from  to  by },
        animateTransform => q{ begin dur  end  min  max  restart  repeatCount
              repeatDur  fill  additive  accumulate calcMode  values
              keyTimes  keySplines  from  to  by calcMode path keyPoints
              rotate origin type attributeName attributeType },
        animateMotion => q{ begin dur  end  min  max  restart  repeatCount
              repeatDur  fill  additive  accumulate calcMode  values
              to  by keyTimes keySplines  from  path  keyPoints
              rotate  origin },
        animateColor => q{ begin dur  end  min  max  restart  repeatCount
              repeatDur  fill  additive  accumulate calcMode  values
              keyTimes  keySplines  from  to  by },
        set => q{ begin dur  end  min  max  restart  repeatCount  repeatDur
              fill to },
    );

    foreach my $k ( keys %rtr ) {
        next if ( $k =~ /\-/ );

        if ( $legal{$name} !~ /\b$k\b/ ) {
            $self->error( "$name.$k" => 'Illegal animation command' );
        }
    }

    return $self->tag( $name, %rtr );
}

sub group {
    my ( $self, %attrs ) = @_;
    return $self->tag( 'g', %attrs );
}

sub STYLE {
    my ( $self, %attrs ) = @_;

    $self->{style} = $self->{style} || {};
    foreach my $k ( keys %attrs ) {
        $self->{style}->{$k} = $attrs{$k};
    }

    return $self;
}

sub mouseaction {
    my ( $self, %attrs ) = @_;

    $self->{mouseaction} = $self->{mouseaction} || {};
    foreach my $k ( keys %attrs ) {
        $self->{mouseaction}->{$k} = $attrs{$k};
    }

    return $self;
}

sub attrib {
    my ( $self, $name, $val ) = @_;

    #verify that the current id is unique. compain on exception
    if ( $name eq 'id' ) {
        if ( $self->getElementByID($val) ) {
            $self->error( $val => 'ID already exists in document' );
            return;
        }
    }

    if ( not defined $val ) {
        if ( scalar(@_) == 2 ) {

            # two arguments only - retrieve
            return $self->{$name};
        }
        else {

            # 3rd argument is undef - delete
            delete $self->{$name};
        }
    }
    else {

        # 3 defined arguments - set
        $self->{$name} = $val;
    }

    return $self;
}
*attr      = \&attrib;
*attribute = \&attrib;

sub cdata {
    my ( $self, @txt ) = @_;
    $self->{-cdata} = join( ' ', @txt );
    return ($self);
}

sub CDATA {
    my ( $self, @txt ) = @_;
    $self->{-CDATA} = join( '\n', @txt );
    return ($self);
}

sub cdata_noxmlesc {
    my ( $self, @txt ) = @_;
    $self->{-cdata_noxmlesc} = join( '\n', @txt );
    return ($self);
}

sub filter {
    my ( $self, %attrs ) = @_;
    return $self->tag( 'filter', %attrs );
}

sub fe {
    my ( $self, %attrs ) = @_;

    return 0 unless ( $attrs{'-type'} );
    my %allowed = (
        blend            => 'feBlend',
        colormatrix      => 'feColorMatrix',
        componenttrans   => 'feComponentTrans',
        Componenttrans   => 'feComponentTrans',
        composite        => 'feComposite',
        convolvematrix   => 'feConvolveMatrix',
        diffuselighting  => 'feDiffuseLighting',
        displacementmap  => 'feDisplacementMap',
        distantlight     => 'feDistantLight',
        flood            => 'feFlood',
        funca            => 'feFuncA',
        funcb            => 'feFuncB',
        funcg            => 'feFuncG',
        funcr            => 'feFuncR',
        gaussianblur     => 'feGaussianBlur',
        image            => 'feImage',
        merge            => 'feMerge',
        mergenode        => 'feMergeNode',
        morphology       => 'feMorphology',
        offset           => 'feOffset',
        pointlight       => 'fePointLight',
        specularlighting => 'feSpecularLighting',
        spotlight        => 'feSpotLight',
        tile             => 'feTile',
        turbulence       => 'feTurbulence',
    );

    my $key     = lc( $attrs{'-type'} );
    my $fe_name = $allowed{ lc($key) } || 'error:illegal_filter_element';
    delete $attrs{'-type'};

    return $self->tag( $fe_name, %attrs );
}

sub pattern {
    my ( $self, %attrs ) = @_;
    return $self->tag( 'pattern', %attrs );
}

sub set {
    my ( $self, %attrs ) = @_;
    return $self->tag( 'set', %attrs );
}

sub stop {
    my ( $self, %attrs ) = @_;
    return $self->tag( 'stop', %attrs );
}

sub gradient {
    my ( $self, %attrs ) = @_;

    my $type = $attrs{'-type'} || 'linear';
    unless ( $type =~ /^(linear|radial)$/ ) {
        $type = 'linear';
    }
    delete $attrs{'-type'};

    return $self->tag( $type . 'Gradient', %attrs );
}

#-------------------------------------------------------------------------------
# Internal methods

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

    if ( $self->{-docref}->{-raiseerror} ) {
        die "$command: $error\n";
    }
    elsif ( $self->{-docref}->{-printerror} ) {
        print STDERR "$command: $error\n";
    }

    $self->{errors}{$command} = $error;
}

# This AUTOLOAD method is activated when '-auto' is passed to SVG.pm
sub autoload {
    my $self = shift;
    my ( $package, $sub ) = ( $AUTOLOAD =~ /(.*)::([^:]+)$/ );

    if ( $sub eq 'DESTROY' ) {
        return $self->release();
    }
    else {

        # the import routine may call us with a tag name involving '-'s
        my $tag = $sub;
        $sub =~ tr/-/_/;

      # N.B.: The \ on \@_ makes sure that the incoming arguments are
      # used and not the ones passed when the subroutine was created.
      # eval "sub $package\:\:$sub (\$;\@) { return shift->tag('$tag',\@_) }";
      #per rt.perl.org comment by slaven.

        if ( !$package->can($sub) ) {
            ## no critic (TestingAndDebugging::ProhibitNoStrict)
            no strict 'refs';
            *{ $package . '::' . $sub }
                = sub { return shift->tag( $tag, @_ ) };
        }
        return $self->$sub(@_) if $self;
    }
}

#-------------------------------------------------------------------------------
# GD Routines

sub colorAllocate {
    my ( $self, $red, $green, $blue ) = @_;
    return 'rgb(' . int($red) . ',' . int($green) . ',' . int($blue) . ')';
}

#-------------------------------------------------------------------------------

1;