File Coverage

blib/lib/XML/Constructor.pm

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

package XML::Constructor;

use warnings;
use strict;
use XML::LibXML;
use Scalar::Util qw/blessed/;
use Carp qw/cluck croak carp/;

=head1 NAME

XML::Constructor - Generate XML from a markup syntax allowing for the abstraction of markup from code

=cut

our $VERSION = '0.01';


sub generate {
  my ( $class, %args ) = @_;
  my ( $parent_node, $data ) =
    @args{ qw( parent_node data ) };

  my $parent  = $class->_get_parent_node($parent_node);

  return $parent unless (ref $data eq 'ARRAY');

  return $class->_generate(parent => $parent, data => $data);
}

sub toString { shift->generate( @_ )->toString }

sub _get_parent_node {
  my ( $class, $parent_node )  = @_;

  if(blessed $parent_node) {
    return $parent_node
      if $class->_validate_parent_object($parent_node);
  }

  return ( ref $parent_node eq 'ARRAY' )
      ? $class->_create_parent_from_arrayref( element => $parent_node )
      : $class->_create_parent_node( $parent_node );
}

sub _generate {
  my ( $class, %args )  = @_;
  my ($parent, $data )  = @args{ qw( parent data ) };

  for my $element ( @$data ) {
    my $method  = $class->_get_dispatch_method($element);

    next unless $method;

    $class->$method( parent => $parent, element => $element );
  }
  return $parent;
}

sub _validate_parent_object {
  my ( $class, $parent_element ) = @_;
  croak "parent element not an object"
    unless blessed $parent_element;

  croak "parent element not decendant of XML::LibXML::(Element|Document)"
    unless ($parent_element->isa("XML::LibXML::Node") ||
            $parent_element->isa("XML::LibXML::Document"));


  return 1;
}

sub _create_parent_node {
  my ( $class, $parent_node_name ) = @_;
  cluck "creating an empty parent node"
    unless(defined $parent_node_name && $parent_node_name =~/\w/);

  return $class->_create_element($parent_node_name);
}

sub _get_dispatch_method {
  my ( $class, $element)   = @_;
  my $method;

  for( ref $element ) {
    $_ eq 'HASH'          && do{$method = '_from_hash'; last};
    $_ eq 'ARRAY'         && do{$method = '_from_array'; last};
    $_ eq 'SCALAR'        && do{$method = '_from_scalar'; last};
  }

  # is element a XML::LibXML::Element object?
  if(!$method && (blessed $element)) {
    $method = '_from_libxml'
      if $element->isa("XML::LibXML::Element");
  }

  carp "cannot process an element in markup [$element]"
    if(!$method);

  return $method;
}

sub _create_parent_from_arrayref {
  my $class   = shift;
  my %args    = @_;
  my( $element )
    = @args{qw/element/};

  my $root  = XML::LibXML::Element->new("");
  # save attribute_title
  my $attribute_title  = $element->[0];

  $class->_from_array( parent => $root, element => $element );

  my $parent  = $root->getChildrenByTagName( $attribute_title );

  die "could not create parent node from ARRAYREF named ".$element->[0]
    unless ( (ref $parent ) && $parent->[0] );

  # return 1st node found
  return $parent->[0];
}

sub _create_element{
  my $class   =shift;
  return XML::LibXML::Element->new( shift || "" )
}

sub _from_hash {
  my ( $class, %args ) = @_;
  my ( $parent, $element ) =
    @args{ qw( parent element ) };

  foreach my $attribute ( keys %$element ) {
    my $value = $element->{$attribute};
    my $obj   = $class->_create_element($attribute);

    if( $value ) {
      if( ref $value ) {
        # kick back to generate
        $class->_generate( parent => $obj, data => [ $value ] );
      }
      else {
        $obj->appendText( $value );
      }
    }
    $parent->addChild( $obj );
  }
}

sub _from_array {
  my ( $class, %args ) = @_;
  my ( $parent, $array ) =
    @args{ qw( parent element ) };

  my $node  = $class->_create_element( shift @$array );

  while( my $attribute = shift @$array ) {
    if( ref $attribute ) {
      $class->_generate( parent => $node, data => [ $attribute ] );
    }
    else {
      # next element in array becomes attribute value
      $node->setAttribute( $attribute, shift @$array );
    }
  }
  $parent->addChild( $node );
}

sub _from_libxml {
  my ( $class, %args ) = @_;
  my ( $parent, $element ) =
    @args{ qw( parent element ) };
  $parent->addChild( $element );
}

sub _from_scalar {
  my ( $class, %args ) = @_;
  my ( $parent, $element ) =
    @args{ qw( parent element ) };

  if ( $$element ) {
    my $string = $$element;
    # removed doubly encoded entites
    # et al XML::DoubleEncodedEntities et al XML::Tiny
    if($string =~ /&(amp|lt|gt|quot|apos);/) {
      $string =~ s/&(lt;|gt;|quot;|apos;|amp;)/
                    $1 eq 'lt;'   ? '<' :
                    $1 eq 'gt;'   ? '>' :
                    $1 eq 'apos;' ? "'" :
                    $1 eq 'quot;' ? '"' :
                                    '&'
                   /ge;
      $element  = \$string;
    }
    $parent->appendText( $$element );
  }
}
1;

__END__