File Coverage

blib/lib/XML/XPathScript/Template.pm

Criterion	Covered	Total	%
statement	71	97	73.2
branch	13	24	54.1
condition	4	15	26.6
subroutine	18	25	72.0
pod	11	11	100.0
total	117	172	68.0

package XML::XPathScript::Template;

use strict;
use warnings;

use Carp;
use Scalar::Util qw/ reftype /;
use Data::Dumper;
use XML::XPathScript::Template::Tag;
use Clone qw/ clone /;
use Scalar::Util qw/ refaddr /;

use overload '&{}'  => \&_overload_func,
             q{""}  => \&_overload_quote;

our $VERSION = '1.54';

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

   my $self = {};
   bless $self, $class;

   return $self;
}

sub set {       ##no critic
    croak "method set called with more than two arguments" if @_ > 3;

    my( $self, $tag, $attribute_ref ) = @_;

    my $type = reftype $tag;
    my @templates =         # templates to change
            !$type           ? $self->{$tag}
                                    ||= new XML::XPathScript::Template::Tag
          : $type eq 'ARRAY' ?  map { $self->{$_}
                                    ||= new XML::XPathScript::Template::Tag
                                    } @$tag
          : croak "tag cannot be of type $type"
          ;

    $_->set( $attribute_ref ) for @templates;

    return;
}

sub copy {
    my( $self, $src, $copy, $attributes_ref ) = @_;

    croak "tag $src not found in template"
        unless $self->{$src};

    my %attributes = %{ $self->{$src} };
    %attributes = map { $_ => $attributes{ $_ } }@$attributes_ref
            if $attributes_ref;

   $self->set( $copy, \%attributes );

   return;
}

sub alias {
    my( $self, $src, $copy ) = @_;

    $self->{$_} = $self->{$src} for ref( $copy ) ? @$copy : $copy;

    return;
}


sub dump {                      ##no critic
    my( $self, @tags ) = @_;

    my %template = %{$self};

    @tags = keys %template unless @tags;

    %template = map { $_ => $template{ $_ } } @tags;

    return Data::Dumper->Dump( [ \%template ], [ 'template' ] );
}

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

    delete $self->{ $_ } for $tags
                                ? @$tags
                                : grep { !/^:/ } keys %$self; ##no critic
    return;
}


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

    my $id = $self->{$tag};

    my @aliases = grep {     $_ ne $tag
                         and refaddr( $self->{$_} ) eq refaddr( $id ) }
                  keys %{$self};

    return @aliases;
}

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

    my $fresh = new XML::XPathScript::Template::Tag;

    $fresh->set( $self->{$tag} );

    $self->{$tag} = $fresh;

    return;
}

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

    return $self->{ ":$namespace" } ||= new XML::XPathScript::Template;
}

sub resolve {
    my $template = shift;
    my( $namespace, $tag ) = @_ == 2 ? @_ : ( undef, @_ );

    no warnings qw/ uninitialized /;
    $namespace = ':'.$namespace;

    return ( ( $template->{$namespace} &&           # selection order
                (  $template->{$namespace}{$tag}    # foo:bar
                || $template->{$namespace}{'*'} ) ) # foo:*
                || $template->{$tag}                # bar
                || $template->{'*'} );              # *
                                                    # (and undef if nothing)
}

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

    carp "incorrect call for import_template(): no argument or is not a template"
        unless $other_template and $other_template =~ /HASH/;

    for my $k ( keys %$other_template ) {
        if ( 0 == index $k, ':' ) {         # it's a namespace
            my $ns = $k;
            $ns =~ s/^://;
            my $subtemplate = $self->namespace( $ns );
            $subtemplate->import( $other_template->{$k} );
        }
        else {                              # it's a regular tag
            $self->set( $k => $other_template->{$k} );
        }
    }

    return;
}

sub _overload_func {
    my $self = shift;
    return sub { $self->set( @_ ) }
}

sub _overload_quote {
    my $self = shift;
    return $self;
    return sub { $self };
}

1;

__END__