File Coverage

blib/lib/XML/Loy.pm

Criterion	Covered	Total	%
statement	330	342	96.4
branch	163	190	85.7
condition	52	75	69.3
subroutine	30	31	96.7
pod	10	10	100.0
total	585	648	90.2

package XML::Loy;
use Mojo::ByteStream 'b';
use Mojo::Loader qw/load_class/;
use Carp qw/croak carp/;
use Scalar::Util qw/blessed weaken/;
use Mojo::Base 'Mojo::DOM';

our $VERSION = '0.49';

sub DESTROY;

# TODO:
#   - Support Mojolicious version > 7.77
#     - "ns|*" namespace selector
#
#  - Add ->clone
#    (Maybe via JSON serialisation of ->tree or using Storable or Dumper)
#
#   Maybe necessary: *AUTOLOAD = \&XML::Loy::AUTOLOAD;
#
# - sub try_further { };
#     # usage:
#     sub author {
#       return $autor or $self->try_further;
#     };
#
#  - ALERT!
#      Do not allow for namespace islands
#      Search $obj->find('* *[xmlns]') and change prefixing
#      After ->SUPER::new;
#      Or:
#      Do allow for namespace islands and check for the
#      namespace to add instead of the package name before
#      prefixing.
#
# - set() should really try to overwrite.
#
# - add() with -before => '' and -after => ''
#   - maybe possible to save to element
#   - Maybe with small changes a change to the object
#     (encoding, xml etc.) can be done
#
# - closest() (jQuery)

our @CARP_NOT;

# Import routine, run when calling the class properly
sub import {
  my $class = shift;

  return unless my $flag = shift;

  return unless $flag =~ /^-?(?i:base|with)$/;

  # Allow for manipulating the symbol table
  no strict 'refs';
  no warnings 'once';

  # The caller is the calling (inheriting) class
  my $caller = caller;
  push @{"${caller}::ISA"}, __PACKAGE__;

  if (@_) {

    # Get class variables
    my %param = @_;

    # Set class variables
    foreach (qw/namespace prefix mime/) {
      if (exists $param{$_}) {
        ${ "${caller}::" . uc $_ } = delete $param{$_};
      };
    };

    # Set class hook
    if (exists $param{on_init}) {
      *{"${caller}::ON_INIT"} = delete $param{on_init};
    };
  };

  # Make inheriting classes strict and modern
  strict->import;
  warnings->import;
  utf8->import;
  feature->import(':5.10');
};


# Return class variables
{
  no strict 'refs';
  sub _namespace { ${"${_[0]}::NAMESPACE"}   || '' };
  sub _prefix    { ${"${_[0]}::PREFIX"}      || '' };
  sub mime       {
    ${ (blessed $_[0] || $_[0]) . '::MIME'}  || 'application/xml'
  };
  sub _on_init   {
    my $class = shift;
    my $self = $class;

    # Run object method
    if (blessed $class) {
      $class = blessed $class;
    }

    # Run class method
    else {
      $self = shift;
    };

    # Run init hook
    if ($class->can('ON_INIT')) {
      *{"${class}::ON_INIT"}->($self) ;
    };
  };
};


# Construct new XML::Loy object
sub new {
  my $class = shift;

  my $self;

  # Create from parent class
  # Empty constructor
  unless ($_[0]) {
    $self = $class->SUPER::new->xml(1);
  }

  # XML::Loy object
  elsif (ref $_[0]) {
    $self = $class->SUPER::new(@_)->xml(1);
  }

  # XML string
  elsif (index($_[0],'<') >= 0 || index($_[0],' ') >= 0) {
    $self = $class->SUPER::new->xml(1)->parse(@_);
  }

  # Create a new node
  else {
    my $name = shift;
    my $att  = ref( $_[0] ) eq 'HASH' ? shift : +{};
    my ($text, $comment) = @_;

    $att->{'xmlns:loy'} = 'http://sojolicio.us/ns/xml-loy';

    # Transform special attributes
    _special_attributes($att) if $att;

    # Create root
    my $tree = [
      'root',
      [ pi => 'xml version="1.0" encoding="UTF-8" standalone="yes"']
    ];

    # Add comment if given
    push(@$tree, [ comment => $comment ]) if $comment;

    # Create Tag element
    my $element = [ tag => $name, $att, $tree ];

    # Add element
    push(@$tree, $element);

    # Add text if given
    push(@$element, [ text => $text ]) if defined $text;

    # Create root element by parent class
    $self = $class->SUPER::new->xml(1);

    # Add newly created tree
    $self->tree($tree);

    # The class is derived
    if ($class ne __PACKAGE__) {

      # Set namespace if given
      if (my $ns = $class->_namespace) {
        $att->{xmlns} = $ns;
      };
    };
  };

  # Start init hook
  $self->_on_init;

  # Return root node
  return $self;
};


# Append a new child node to the XML Node
sub add {
  my $self = shift;

  # Store tag
  my $tag = $_[0];

  # If node is root, use first element
  if (!$self->parent &&
        ref($self->tree->[1]) &&
        ref($self->tree->[1]) eq 'ARRAY' &&
        $self->tree->[1]->[0] eq 'pi') {
    $self = $self->at('*');
  };

  # Add element
  my $element = $self->_add_clean(@_) or return;

  my $tree = $element->tree;

  # Prepend with no prefix
  if (index($tag, '-') == 0) {
    $tree->[1] = substr($tag, 1);
    return $element;
  };

  # Element is no tag
  return $element unless $tree->[0] eq 'tag';

  # Prepend prefix if necessary
  my $caller = caller;
  my $class  = ref $self;

  # Caller and class are not the same
  if ($caller ne $class && $caller->can('_prefix')) {
    if ((my $prefix = $caller->_prefix) && $caller->_namespace) {
      $element->tree->[1] = "${prefix}:$tag";
    };
  };

  # Return element
  return $element;
};


# Append a child only once to the XML node.
sub set {
  my $self = shift;

  my $tag;

  # If node is root, use first element
  if (!$self->parent && $self->tree->[1]->[0] eq 'pi') {
    $self = $self->at('*');
  };

  # Get tag from document object
  if (ref $_[0]) {
    $tag = $_[0]->at('*')->tag;
  }

  # Get tag
  else {

    # Store tag
    $tag = shift;

    # No prefix
    if (index($tag, '-') == 0) {
      $tag = substr($tag, 1);
    }

    # Maybe prefix
    else {
      # Prepend prefix if necessary
      my $caller = caller;
      my $class  = ref $self;

      # Caller and class are not the same
      if ($caller ne $class && $caller->can('_prefix')) {
        if ((my $prefix = $caller->_prefix) && $caller->_namespace) {
          $tag = "${prefix}:$tag";
        };
      };
    };
  };

  my $att = $self->tree->[2];

  # Introduce attribute 'once'
  $att->{'loy:once'} //= '';

  # Check if set to once
  if (index($att->{'loy:once'}, "($tag)") >= 0) {

    # Todo: Maybe escaping - check in extensions
    $self->children("$tag")->map('remove');
  }

  # Set if not already set
  else {
    $att->{'loy:once'} .= "($tag)";
  };

  # Add a ref, not the tag
  unshift(@_, $tag) unless blessed $_[0];

  # Add element (Maybe prefixed)
  return $self->_add_clean(@_);
};


# Children of the node
sub children {
  my ($self, $type) = @_;

  # This method is a modified version of
  # the children method of Mojo::DOM
  # It works as written in the documentation,
  # but is also aware of namespace prefixes.

  # If node is root, use first element
  if (!$self->parent &&
        ref($self->tree->[1]) &&
        ref($self->tree->[1]) eq 'ARRAY' &&
        $self->tree->[1]->[0] eq 'pi') {
    $self = $self->at('*');
  };

  my @children;
  my $xml     = $self->xml;
  my $tree    = $self->tree;
  my $type_l  = $type ? length $type : 0;
  for my $e (@$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree]) {

    # Make sure child is the right type
    next unless $e->[0] eq 'tag';

    # Type is given
    if (defined $type) {

      # Type is already prefixed or element is not prefixed
      if (index($type, ':') > 0 || index($e->[1], ':') < 0) {
        next if $e->[1] ne $type;
      }

      # Check, if type is valid, and ignore prefixes, cause tag is prefixed
      elsif (index($e->[1], ':') > 0) {
        next if substr($e->[1], (index($e->[1], ':') + 1)) ne $type;
      };
    };

    push(@children, $self->new->tree($e)->xml($xml));
  }

  # Create new Mojo::Collection
  return Mojo::Collection->new( @children );
};


# Append a new child node to the XML Node
sub _add_clean {
  my $self = shift;

  # Node is a node object
  if (ref $_[0]) {

    # Serialize node
    my $node = $self->SUPER::new->xml(1)->tree( shift->tree );

    # Get root attributes
    my $root_attr = $node->_root_element->[2];

    # Push namespaces to new root
    foreach ( grep( index($_, 'xmlns:') == 0, keys %$root_attr ) ) {

      # Strip xmlns prefix
      $_ = substr($_, 6);

      # Add namespace
      $self->namespace( $_ => delete $root_attr->{ "xmlns:$_" } );
    };

    # Delete namespace information, if already set
    if (exists $root_attr->{xmlns}) {

      # Namespace information can be deleted
      if (my $ns = $self->namespace) {
        delete $root_attr->{xmlns} if $root_attr->{xmlns} eq $ns;
      };
    };

    # Get root of parent node
    my $base_root_attr = $self->_root_element->[2];

    # Copy extensions
    if (exists $root_attr->{'loy:ext'}) {
      my $ext = $base_root_attr->{'loy:ext'};

      $base_root_attr->{'loy:ext'} =
        join('; ', $ext, split(/;\s/, delete $root_attr->{'loy:ext'}));
    };


    # Delete pi from node
    my $sec = $node->tree->[1];
    if (ref $sec eq 'ARRAY' && $sec->[0] eq 'pi') {
      splice( @{ $node->tree }, 1,1 );
    };

    # Append new node
    $self->append_content($node);

    # Return first child
    return $self->children->[-1];
  }

  # Node is a string
  else {
    my $name = shift;

    # Pretty sloppy check for valid names
    return unless $name =~ m!^-?[^\s<>]+$!;

    my $att  = shift if ref( $_[0] ) eq 'HASH';
    my ($text, $comment) = @_;

    # Node content with text
    my $string = "<$name";

    if (defined $text) {
      $string .= '>' . b($text)->trim->xml_escape . "";
    }

    # Empty element
    else {
      $string .= ' />';
    };

    # Append new node
    $self->append_content( $string );

    # Get first child
    my $node = $self->children->[-1];

    # Attributes were given
    if ($att) {

      # Transform special attributes
      _special_attributes($att);

      # Add attributes to node
      $node->attr($att);
    };

    # Add comment
    $node->comment($comment) if $comment;

    return $node;
  };
};


# Transform special attributes
sub _special_attributes {
  my $att = shift;

  foreach ( grep { index($_, '-') == 0 } keys %$att ) {

    # Set special attribute
    $att->{'loy:' . substr($_, 1) } = lc delete $att->{$_};
  };
};


# Prepend a comment to the XML node
sub comment {
  my $self = shift;

  my $parent;

  # If node is root, use first element
  return $self unless $parent = $self->parent;

  # Find previous sibling
  my $previous;

  # Find previous node
  for my $e (@{$parent->tree}) {
    last if $e eq $self->tree;
    $previous = $e;
  };

  # Trim and encode comment text
  my $comment_text = b( shift )->trim->xml_escape;

  # Add to previous comment
  if ($previous && $previous->[0] eq 'comment') {
    $previous->[1] .= '; ' . $comment_text;
  }

  # Create new comment node
  else {
    $self->prepend("");
  };

  # Return node
  return $self;
};


# Add extension to document
sub extension {
  my $self = shift;

  # Get root element
  my $root = $self->_root_element;

  # No root to associate extension to
  unless ($root) {
    carp 'There is no document to associate the extension with';
    return;
  };

  # Get ext string
  my @ext = split(/;\s/, $root->[2]->{'loy:ext'} || '');

  return @ext unless $_[0];

  # New Loader
  # my $loader = Mojo::Loader->new;

  # Try all given extension names
  while (my $ext = shift( @_ )) {

    next if grep { $ext eq $_ } @ext;

    # Default 'XML::Loy::' prefix
    if (index($ext, '-') == 0) {
      $ext =~ s/^-/XML::Loy::/;
    };

    # Unable to load extension
    if (my $e = load_class $ext) {
      carp "Exception: $e"  if ref $e;
      carp qq{Unable to load extension "$ext"};
      next;
    };

    # Add extension to extensions list
    push(@ext, $ext);

    # Start init hook
    $ext->_on_init($self);

    if ((my $n_ns = $ext->_namespace) &&
    (my $n_pref = $ext->_prefix)) {
      $root->[2]->{"xmlns:$n_pref"} = $n_ns;
    };
  };

  # Save extension list as attribute
  $root->[2]->{'loy:ext'} = join('; ', @ext);

  return $self;
};


# Get or add namespace to root
sub namespace {
  my $self = shift;

  # Get namespace
  unless ($_[0]) {
    return $self->SUPER::namespace || undef;
  };

  my $ns = pop;
  my $prefix = shift;

  # Get root element
  my $root = $self->_root_element;

  # No warning, but not able to set
  return unless $root;

  # Save namespace as attribute
  $root->[2]->{'xmlns' . ($prefix ? ":$prefix" : '')} = $ns;
  return $prefix;
};


# As another object
sub as {
  my $self = shift;

  # Base object
  my $base = shift;

  # Default 'XML::Loy::' prefix
  if (index($base, '-') == 0) {
    for ($base) {

      # Was Loy prefix
      s/^-Loy$/XML::Loy/;
      s/^-/XML::Loy::/;
    };
  };

  # Unable to load extension
  if (my $e = load_class $base) {
    carp "Exception: $e"  if ref $e;
    carp qq{Unable to load base class "$e"};
    return;
  };

  # Create new base document
  my $xml = $base->new( $self->to_string );

  # Start init hook
  $xml->_on_init;

  # Set base namespace
  if ($base->_namespace) {
    $xml->namespace( $base->_namespace );
  };

  # Delete extension information
  $xml->find('*[loy\:ext]')->each(
    sub {
      delete $_->{attrs}->{'loy:ext'}
    }
  );

  # Add extensions
  $xml->extension( @_ );

  # Return XML document
  return $xml;
};


# Render as pretty xml
sub to_pretty_xml {
  my $self = shift;
  return _render_pretty( shift // 0, $self->tree);
};


# Render subtrees with pretty printing
sub _render_pretty {
  my $i    = shift; # Indentation
  my $tree = shift;

  my $e = $tree->[0];

  # No element
  croak('No element') and return unless $e;

  # Element is tag
  if ($e eq 'tag') {
    my $subtree = [
      @{ $tree }[ 0 .. 2 ],
      [
        @{ $tree }[ 4 .. $#$tree ]
      ]
    ];

    return _element($i, $subtree);
  }

  # Element is text
  elsif ($e eq 'text') {

    my $escaped = $tree->[1];

    for ($escaped) {
      next unless $_;

      # Escape and trim whitespaces from both ends
      $_ = b($_)->xml_escape->trim;
    };

    return $escaped;
  }

  # Element is comment
  elsif ($e eq 'comment') {

    # Padding for every line
    my $p = '  ' x $i;
    my $comment = join "\n$p     ", split(/;\s+/, $tree->[1]);

    return "\n" . ('  ' x $i) . "\n";

  }

  # Element is processing instruction
  elsif ($e eq 'pi') {
    return ('  ' x $i) . '[1] . "?>\n";
  }

  # Element is root
  elsif ($e eq 'root') {

    my $content;

    # Pretty print the content
    $content .= _render_pretty( $i, $tree->[ $_ ] ) for 1 .. $#$tree;

    return $content;
  };
};


# Render element with pretty printing
sub _element {
  my $i = shift;
  my ($type, $qname, $attr, $child) = @{ shift() };

  # Is the qname valid?
  croak "$qname is no valid QName"
    unless $qname =~ /^(?:[a-zA-Z_]+:)?[^\s]+$/;

  # Start start tag
  my $content = ('  ' x $i) . "<$qname";

  # Add attributes
  $content .= _attr(('  ' x $i). (' ' x ( length($qname) + 2)), $attr);

  # Has the element a child?
  if ($child->[0]) {

    # Close start tag
    $content .= '>';

    # There is only a textual child - no indentation
    if (!$child->[1] && ($child->[0] && $child->[0]->[0] eq 'text')) {

      # Special content treatment
      if (exists $attr->{'loy:type'}) {

        # With base64 indentation
        if ($attr->{'loy:type'} =~ /^armour(?::(\d+))?$/i) {
          my $n = $1 || 60;

          my $string = $child->[0]->[1];

          # Delete whitespace
          $string =~ tr{\t-\x0d }{}d;

          # Introduce newlines after n characters
          $content .= "\n" . ('  ' x ($i + 1));
          $content .= join  "\n" . ( '  ' x ($i + 1) ), (unpack "(A$n)*", $string );
          $content .= "\n" . ('  ' x $i);
        }

        # No special treatment
        else {

          # Escape
          $content .= b($child->[0]->[1])->trim->xml_escape;
        };
      }

      # No special content treatment indentation
      else {

        # Escape
        $content .= b($child->[0]->[1])->trim->xml_escape;
      };
    }

    # Treat children special
    elsif (exists $attr->{'loy:type'}) {

      # Raw
      if ($attr->{'loy:type'} eq 'raw') {
        foreach (@$child) {

          # Create new dom object
          my $dom = __PACKAGE__->new;
          $dom->xml(1);

          # Print without prettifying
          $content .= $dom->tree($_)->to_string;
        };
      }

      # Todo:
      elsif ($attr->{'loy:type'} eq 'escape') {
        $content .= "\n";

        foreach (@$child) {

          # Create new dom object
          my $dom = __PACKAGE__->new;
          $dom->xml(1);

          # Pretty print
          my $string = $dom->tree($_)->to_pretty_xml($i + 1);

          # Encode
          $content .= b($string)->xml_escape;
        };

        # Correct Indent
        $content .= '  ' x $i;
      };
    }

    # There are a couple of children
    else {

      my $offset = 0;

      # First element is unformatted textual
      if (!exists $attr->{'loy:type'} &&
            $child->[0] &&
            $child->[0]->[0] eq 'text') {

        # Append directly to the last tag
        $content .= b($child->[0]->[1])->trim->xml_escape;
        $offset = 1;
      };

      # Start on a new line
      $content .= "\n";

      # Loop through all child elements
      foreach (@{$child}[ $offset .. $#$child ]) {

        # Render next element
        $content .= _render_pretty( $i + 1, $_ );
      };

      # Correct Indent
      $content .= ('  ' x $i);
    };

    # End Tag
    $content .= "\n";
  }

  # No child - close start element as empty tag
  else {
    $content .= " />\n";
  };

  # Return content
  return $content;
};


# Render attributes with pretty printing
sub _attr {
  my $indent_space = shift;
  my %attr = %{$_[0]};

  # Delete special and namespace attributes
  my @special = grep {
    $_ eq 'xmlns:loy' || index($_, 'loy:') == 0
  } keys %attr;

  # Delete special attributes
  delete $attr{$_} foreach @special;

  # Prepare attribute values
  $_ = b($_)->xml_escape->quote foreach values %attr;

  # Return indented attribute string
  if (keys %attr) {
    return ' ' .
      join "\n$indent_space", map { "$_=" . $attr{$_} } sort keys %attr;
  };

  # Return nothing
  return '';
};


# Get root element (not as an object)
sub _root_element {
  my $self = shift;

  # Todo: Optimize! Often called!

  # Find root (Based on Mojo::DOM::root)
  my $root = $self->tree or return;
  my $tag;

  # Root is root node
  if ($root->[0] eq 'root') {
    my $i = 1;

    # Search for the first tag
    $i++ while $root->[$i] && $root->[$i]->[0] ne 'tag';

    # Tag found
    $tag = $root->[$i];
  }

  # Root is a tag
  else {

    # Tag found
    while ($root->[0] eq 'tag') {
      $tag = $root;

      last unless my $parent = $root->[3];

      $root = $parent;
    };
  };

  # Return root element
  return $tag;
};


# Autoload for extensions
sub AUTOLOAD {
  my $self = shift;
  my @param = @_;

  # Split parameter
  my ($package, $method) = our $AUTOLOAD =~ /^([\w\:]+)\:\:(\w+)$/;

  # Choose root element
  my $root = $self->_root_element;

  # Get extension array
  my @ext = $self->extension;

  {
    no strict 'refs';

    foreach (@ext) {

      # Method does not exist in extension
      next unless $_->can($method);

      # Release method
      return *{ "${_}::$method" }->($self, @param);
    };
  };

  my $errstr = qq{Can't locate "${method}" in "$package"};
  if (@ext) {
    $errstr .= ' with extension' . (@ext > 1 ? 's' : '');
    $errstr .= ' "' . join('", "', @ext) . '"';
  };

  carp $errstr and return;
};


1;


__END__