File Coverage

blib/lib/CAM/XML.pm

Criterion	Covered	Total	%
statement	28	336	8.3
branch	1	150	0.6
condition	0	72	0.0
subroutine	7	37	18.9
pod	19	19	100.0
total	55	614	8.9

package CAM::XML;

use 5.006;
use strict;
use warnings;
use CAM::XML::Text;
use English qw(-no_match_vars);
use Carp;

our $VERSION = '1.14';

=for stopwords XHTML XPath pre-formatted attr1 attr2

=head1 NAME

CAM::XML - Encapsulation of a simple XML data structure

=head1 LICENSE

Copyright 2006 Clotho Advanced Media, Inc.,

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SYNOPSIS

  my $pollTag = CAM::XML->new('poll');

  foreach my $q (@questions) {
    my $questionTag = CAM::XML->new('question');

    $questionTag->add(-text => $q->{text});
    my $choicesTag = CAM::XML->new('choices');

    foreach my $c (@{$q->{choices}}) {
      my $choiceTag = CAM::XML->new('choice');
      $choiceTag->setAttributes('value', $c->{value});
      $choiceTag->add(-text => $c->{text});
      $choicesTag->add($choiceTag);
    }
    $questionTag->add($choicesTag);
    $pollTag->add($questionTag);
  }
  print CAM::XML->header();
  print $pollTag->toString();

=head1 DESCRIPTION

This module reads and writes XML into a simple object model.  It is
optimized for ease of creating code that interacts with XML.

This module is not as powerful or as standards-compliant as say
XML::LibXML, XML::SAX, XML::DOM, etc, but it's darn easy to use.  I
recommend it to people who want to just read/write a quick but valid
XML file and don't want to bother with the bigger modules.

In our experience, this module is actually easier to use than
XML::Simple because the latter makes some assumptions about XML
structure that prevents it from handling all XML files well.  YMMV.

However, one exception to the simplicity claimed above is our
implementation of a subset of XPath.  That's not very simple.  Sorry.

=head1 CLASS METHODS

=over

=item $pkg->parse($xmlstring)

=item $pkg->parse(-string => $xmlstring)

=item $pkg->parse(-filename => $xmlfilename)

=item $pkg->parse(-filehandle => $xmlfilehandle)

Parse an incoming stream of XML into a CAM::XML hierarchy.  This
method just hands the first argument off to XML::Parser, so it can
accept any style of argument that XML::Parser can.  Note that XML::Parser
says the filehandle style should pass an IO::Handle object.  This can
be called as a class method or an instance method.

Additional meaningful flags:

  -cleanwhitespace => 1

Traverse the document and remove non-significant whitespace, as per
removeWhitespace().

  -xmlopts => HASHREF

Any options in this hash are passed directly to XML::Parser.

NOTE: this method does NOT work well on subclasses.  I tried, but
failed to fix it up.  The problems is that CAM::XML::XMLTree has to be
able to instantiate one of this class, but there's no really good way
to communicate with it yet.

=cut

sub parse
{
   my $pkg_or_self = shift;
   my $mode;
   if ($_[0] =~ m/\A-/xms)    # If no mode was specified, imply one
   {
      $mode = shift;
   }
   else
   {
      $mode = '-string';
   }
   my $xml   = shift;
   my %flags = (@_);

   local $SIG{__DIE__};
   local $SIG{__WARN__};
   require CAM::XML::XMLTree;
   require XML::Parser;
   my $pkg = ref $pkg_or_self;
   if (!$pkg)
   {
      $pkg = $pkg_or_self;
   }
   my $p = XML::Parser->new(Style => $pkg.'::XMLTree',
                            $flags{-xmlopts} ? %{$flags{xmlopts}} : ());
   my $self;
   if ($mode eq '-filename')
   {
      if (open my $fh, '<', $xml)
      {
         local $INPUT_RECORD_SEPARATOR = undef;
         eval {
            $self = $p->parse(<$fh>);
         };
         close $fh;
      }
   }
   else
   {
      eval {
         $self = $p->parse($xml);
      };
   }
   if ($self && $flags{-cleanwhitespace})
   {
      $self->removeWhitespace();
   }
   return $self;
}

=item $pkg->new($tagname)

=item $pkg->new($tagname, attr1 => $value1, attr2 => $value2, ...)

Create a new XML tag.  Optionally, you can set tag attributes at the
same time.

=cut

sub new
{
   my $pkg  = shift;
   my $name = shift;

   if (!$name)
   {
      croak 'No XML tag name specified';
   }

   my $self = bless {
      name       => $name,
      attributes => {},
      children   => [],
   }, $pkg;

   return $self->setAttributes(@_);
}

=item $pkg->header()

=item $self->header()

Return a string containing the following message, suffixed by a newline:



=cut

sub header
{
   return qq[\n];
}

=back

=head1 INSTANCE METHODS

=over

=item $self->getName()

Returns the name of the node.

=cut

sub getName
{
   my $self = shift;
   return $self->{name};
}

=item $self->setAttributes(attr1 => $value1, attr2 => $value2, ...)

Set the value of one or more XML attributes.  If any keys are
duplicated, only the last one set is recorded.

=cut

sub setAttributes
{
   my $self = shift;

   while (@_ > 0)
   {
      my $key   = shift;
      my $value = shift;
      if (!defined $key || $key eq q{})
      {
         croak 'Invalid key specified';
      }
      $self->{attributes}->{$key} = $value;
   }
   return $self;
}

=item $self->deleteAttribute($key)

Remove the specified attribute if it exists.

=cut

sub deleteAttribute
{
   my $self = shift;
   my $key = shift;

   delete $self->{attributes}->{$key};
   return $self;
}

=item $self->getAttributeNames()

Returns a list of the names of all the attributes of this node.  The
names are returned in arbitrary order.

=cut

sub getAttributeNames
{
   my $self = shift;

   return keys %{ $self->{attributes} };
}

=item $self->getAttributes()

Returns a hash of all attributes.

=cut

sub getAttributes
{
   my $self = shift;

   return %{ $self->{attributes} };
}

=item $self->getAttribute($key)

Returns the value of the named attribute, or undef if it does not exist.

=cut

sub getAttribute
{
   my $self = shift;
   my $key  = shift;

   return $key ? $self->{attributes}->{$key} : undef;
}

=item $self->getChildren()

Returns an array of XML nodes and text objects contained by this node.

=cut

sub getChildren
{
   my $self = shift;
   return @{ $self->{children} };
}

=item $self->getChild($index)

Returns a child of this node.  The argument is a zero-based index.
Returns undef if the index is not valid.

=cut

sub getChild
{
   my $self  = shift;
   my $index = shift;

   return if (!defined $index || $index !~ m/\A\d+\z/xms);
   return $self->{children}->[$index];
}

=item $self->getChildNodes()

Returns an array of XML nodes contained by this node (that is, unlike
getChildren(), text nodes are ignored).

=cut

sub getChildNodes
{
   my $self = shift;

   return grep { $_->isa(__PACKAGE__) } @{ $self->{children} };
}

=item $self->getChildNode($index)

Returns a CAM::XML child of this node (that is, unlike getChild(),
text nodes are ignored.  The argument is a zero-based index.  Returns
undef if the index is not valid.

=cut

sub getChildNode
{
   my $self  = shift;
   my $index = shift;

   return if (!defined $index || $index !~ m/\A\d+\z/xms);
   my @kids = grep { $_->isa(__PACKAGE__) } @{ $self->{children} };
   return $kids[$index];
}

=item $self->setChildren($node1, $node2, ...)

Removes all the children from this node and replaces them with the
supplied values.  All of the values MUST be CAM::XML or CAM::XML::Text
objects, or this method will abort and return false before any changes
are made.

=cut

sub setChildren
{
   my $self = shift;

   my @good = grep { defined $_ && ref $_ &&
                     ($_->isa(__PACKAGE__) || $_->isa('CAM::XML::Text')) } @_;
   if (@good != @_)
   {
      croak 'Attempted to add bogus XML node';
   }

   @{ $self->{children} } = @good;
   return $self;
}

=item $self->add(CAM::XML instance)

=item $self->add(-text => $text)

=item $self->add(-cdata => $text)

=item $self->add(-xml => $rawxml)

=item $self->add()

Add content within the current tag.  Order of addition may be
significant.  This content can be any one of 1) subsidiary XML tags
(CAM::XML), 2) literal text content (C<-text> or C<-cdata>), or 3)
pre-formatted XML content (C<-xml>).

In C<-text> and C<-cdata> content, any reserved characters will be
automatically escaped.  Those two modes differ only in their XML
representation: C<-cdata> is more human-readable if there are a lot of
"&", "<" and ">" characters in your text, where C<-text> is usually more
compact for short strings.  These strings are not escaped until
output.

Content in C<-xml> mode is parsed in as CAM::XML objects.  If it is not
valid XML, a warning will be emitted and the add will fail.

=cut

sub add
{
   my $self = shift;

   while (@_ > 0)
   {
      my $add = shift;

      # Test different kinds of input
        !$add                                   ? croak 'Undefined object'
      : ref $add && $add->isa(__PACKAGE__)      ? push @{ $self->{children} }, $add
      : ref $add && $add->isa('CAM::XML::Text') ? push @{ $self->{children} }, $add
      : ref $add                                ? croak 'Invalid object type to add to a CAM::XML node'
      : $add =~ m/\A-(text|cdata)\z/xms         ? $self->_add_text($1, shift)
      : $add eq '-xml'                          ? $self->_add_xml(shift)
      : croak "Unknown flag '$add'.  Expected '-text' or '-cdata' or '-xml'";
   }

   return $self;
}

sub _add_text
{
   my $self = shift;
   my $type = shift;
   my $text = shift;

   if (!defined $text)
   {
      $text = q{};
   }

   # If the previous element was the same kind of text item
   # then merge them.  Otherwise append this text item.

   if (@{ $self->{children} } > 0 &&
       $self->{children}->[-1]->isa('CAM::XML::Text') &&
       $self->{children}->[-1]->{type} eq $type)
   {
      $self->{children}->[-1]->{text} .= $text;
   }
   else
   {
      push @{ $self->{children} }, CAM::XML::Text->new($type => $text);
   }
   return;
}

sub _add_xml
{
   my $self = shift;
   my $xml  = shift;

   my $parsed = $self->parse($xml);
   if ($parsed)
   {
      $self->add($parsed);
   }
   else
   {
      croak 'Tried to add invalid XML content';
   }
   return;
}

=item $self->removeWhitespace()

Clean out all non-significant whitespace.  Whitespace is deemed
non-significant if it is bracketed by tags.  This might not be true in
some data formats (e.g. HTML) so don't use this function carelessly.

=cut

sub removeWhitespace
{
   my $self = shift;

   my @delete_indices  = ();
   my $lasttag = -1;
   foreach my $i (0 .. $#{ $self->{children} })
   {
      my $child = $self->{children}->[$i];
      if ($child->isa(__PACKAGE__))
      {
         if (defined $lasttag)
         {
            push @delete_indices, ($lasttag + 1) .. ($i - 1);
         }
         $child->removeWhitespace();
         $lasttag = $i;
      }
      elsif ($child->{text} =~ m/\S/xms) # CAM::XML::Text instance
      {
         $lasttag = undef;
      }
   }
   if (defined $lasttag)
   {
      push @delete_indices, ($lasttag + 1) .. $#{ $self->{children} };
   }
   while (@delete_indices > 0)
   {
      my $node_index = pop @delete_indices;
      splice @{ $self->{children} }, $node_index, 1;
   }
   return $self;
}

=item $self->getInnerText()

For the given node, descend through all of its children and
concatenate all the text values that are found.  If none, this method
returns an empty string (not undef).

=cut

sub getInnerText
{
   my $self = shift;

   my $text  = q{};
   my @stack = ([@{ $self->{children} }]);
   while (@stack > 0)
   {
      my $list  = $stack[-1];
      my $child = shift @{$list};
      if ($child)
      {
         if ($child->isa(__PACKAGE__))
         {
            push @stack, [@{ $child->{children} }];
         }
         else # CAM::XML::Text
         {
            $text .= $child->{text};
         }
      }
      else
      {
         pop @stack;
      }
   }
   return $text;
}

=item $self->getNodes(-tag => $tagname)

=item $self->getNodes(-attr => $attrname, -value => $attrvalue)

=item $self->getNodes(-path => $path)

Return an array of CAM::XML objects representing nodes that match the
requested properties.

A path is a syntactic path into the XML doc something like an XPath

  '/' divides nodes
  '//' means any number of nodes
  '/[n]' means the nth child of a node (1-based)
  '[n]' means the nth instance of this node
  '/[-n]' means the nth child of a node, counting backward
  '/[last()]' means the last child of a node (same as [-1])
  '/[@attr="value"]' means a node with this attribute value
  '/text()' means all of the text data inside a node
            (note this returns just one node, not all the nodes)

For example, C
searches an XHTML body for all tables, and returns all anchor nodes in
the first row which pop new windows.

Please note that while this syntax resembles XPath, it is FAR from a
complete (or even correct) implementation.  It's useful for basic
delving into an XML document, however.

=cut

sub getNodes
{
   my $self     = shift;
   my %criteria = (@_);

   if ($criteria{-path})
   {
      # This is a very different beast.  Handle it separately.
      return $self->_get_path_nodes($criteria{-path}, [$self]);
   }

   my @list  = ();
   my @stack = ([$self]);
   while (@stack > 0)
   {
      my $list = $stack[-1];
      my $obj  = shift @{$list};
      if ($obj)
      {
         if ($obj->isa(__PACKAGE__))
         {
            push @stack, [@{ $obj->{children} }];
            if (($criteria{-tag} && $criteria{-tag} eq $obj->{name}) ||
                ($criteria{-attr} && exists $obj->{attributes}->{$criteria{-attr}} &&
                 $obj->{attributes}->{$criteria{-attr}} eq $criteria{-value}))
            {
               push @list, $obj;
            }
         }
      }
      else
      {
         pop @stack;
      }
   }
   return @list;
}

# Internal use only

sub _get_path_nodes
{
   my $self = shift;
   my $path = shift;
   my $kids = shift || $self->{children};

   my @list = !$path                                   ? $self
            : $path =~ m,\A /?text\(\)          \z,xms ? $self->_get_path_nodes_text()
            : $path =~ m,\A /?\[(\d+)\](.*)     \z,xms ? $self->_get_path_nodes_easyindex($kids, $1, $2)
            : $path =~ m,\A /?\[([^\]]+)\](.*)  \z,xms ? $self->_get_path_nodes_index($kids, $1, $2)
            : $path =~ m,\A //+                 \z,xms ? $self->_get_path_nodes_all($kids, $path)
            : $path =~ m,   (/?)(/?)([^/]+)(.*) \z,xms ? $self->_get_path_nodes_match($kids, $path, $1, $2, $3, $4)
            : croak "path not understood: '$path'";

   return @list;
}


sub _get_path_nodes_text
{
   my $self = shift;

   return CAM::XML::Text->new(text => $self->getInnerText());
}

sub _get_path_nodes_easyindex
{
   my $self = shift;
   my $kids = shift;
   my $num  = shift;
   my $rest = shift;

   # this is a special case of _get_path_nodes_index
   # it's higher performance since we can go straight to the
   # index instead of looping

   my $match = $kids->[$num - 1];
   return $match ? $match->_get_path_nodes($rest) : ();
}

sub _get_path_nodes_index
{
   my $self  = shift;
   my $kids  = shift;
   my $limit = shift;
   my $rest  = shift;

   my $index = 0;
   my @list;
   foreach my $node (@{$kids})
   {
      ++$index;    # one-based
      if ($self->_match($node, undef, $limit, $index, scalar @{$kids}))
      {
         push @list, $node->_get_path_nodes($rest);
      }
   }
   return @list;
}

sub _get_path_nodes_all
{
   my $self = shift;
   my $kids = shift;
   my $path = shift;

   my @list;
   foreach my $node (@{$kids})
   {
      if ($node->isa(__PACKAGE__))
      {
         push @list, $node, $node->_get_path_nodes($path);
      }
   }
   return @list;
}

sub _get_path_nodes_match
{
   my $self  = shift;
   my $kids  = shift;
   my $path = shift;
   my $base  = shift;
   my $any   = shift;
   my $match = shift;
   my $rest  = shift;

   my @list;
   my $limit = undef;
   if ($match =~ s,\[([^\]]+)\]\z,,xms)
   {
      $limit = $1;
      if (!$limit)
      {
         croak "bad index in path (indices are one-based): '$path'";
      }
   }
   if ($match && $limit)
   {
      # This is a special case that arose from a bug in _match()
      # TODO: move the @group and $index logic into _match()
      my @group;
      my $index = 0;
      my $max   = 0;
      foreach my $node (@{$kids})
      {
         ++$index;    # one-based
         if ($self->_match($node, $match, undef, $index, scalar @{$kids}))
         {
            push @group, 1;
            $max++;
         }
         else
         {
            push @group, 0;
         }
      }
      $index = 0;
      foreach my $i (0 .. $#{$kids})
      {
         my $node = $kids->[$i];
         if ($group[$i])
         {
            ++$index;    # one-based
            if ($self->_match($node, undef, $limit, $index, $max))
            {
               push @list, $node->_get_path_nodes($rest);
            }
         }
         if ($any)
         {
            push @list, $node->_get_path_nodes($path);
         }
      }
   }
   elsif ($match || $limit)
   {
      my $index = 0;
      foreach my $node (@{$kids})
      {
         ++$index;    # one-based
         if ($self->_match($node, $match, $limit, $index, scalar @{$kids}))
         {
            push @list, $node->_get_path_nodes($rest);
         }
         if ($any)
         {
            push @list, $node->_get_path_nodes($path);
         }
      }
   }
   else
   {
      die 'Internal error: neither match nor limit were true';
   }
   return @list;
}

sub _match
{
   my $self  = shift;
   my $node  = shift;
   my $tag   = shift;
   my $limit = shift;
   my $index = shift;    # one-based
   my $max   = shift;

   if ($tag && $limit)
   {
      die 'Internal error: _match() is broken for simultaneous tag and index matches';
      # currently, the $tag && $limit case is handled externally.
      # TODO: handle this better
   }

   my $is_element = $node->isa(__PACKAGE__);
   if ($tag)
   {
      return if (!$is_element);
      return if ($node->{name} ne $tag);
   }
   if ($limit)
   {
      # massaging
      if ($limit eq 'last()')
      {
         $limit = -1;
      }

      if ($limit =~ m/\A\-\d+/xms)
      {
         return if ($max + $limit + 1 != $index);
      }
      elsif ($limit =~ m/\A\d+/xms)
      {
         return if ($limit != $index);
      }
      elsif ($limit =~ m/\A\@(\w+)=\"([^\"]*)\"\z/xms ||
             $limit =~ m/\A\@(\w+)=\'([^\']*)\'\z/xms)
      {
         return if (!$is_element);
         my $attr = $1;
         my $val  = $2;
         my $cmp  = $node->{attributes}->{$attr};
         return if (!defined $cmp || $val ne $cmp);
      }
      else
      {
         croak "path predicate not understood: '$limit'";
      }
   }
   return $self;
}

=item $self->toString([OPTIONS])

Serializes the tag and all subsidiary tags into an XML string.  This
is called recursively on any subsidiary CAM::XML objects.  Note that
the XML header is not prepended to this output.

The following optional arguments apply:

  -formatted => boolean
        If true, the XML is indented nicely.  Otherwise, no whitespace
        is inserted between tags.
  -textformat => boolean
        Only relevent if -formatted is true.  If false, this prevents
        the formatting of pure text values.
  -level => number
        Indents this tag by the number of levels indicated.  This implies
        -formatted => 1
  -indent => number
        The number of spaces to indent per level if the output is
        formatted.  By default, this is 2 (i.e. two spaces).

Example: -formatted => 0

   Baz

Example: -formatted => 1



       Baz



Example: C<-formatted =E 1, textformat =E 0>


     Baz


Example: C<-formatted =E 1, textformat =E 0, -indent =E 4>


       Baz


=cut

sub toString
{
   my $self = shift;
   my %args = (@_);

   if ($args{'-formatted'} && !exists $args{'-level'})
   {
      $args{'-level'} = 0;
      if (!exists $args{'-textformat'})
      {
         $args{'-textformat'} = 1;
      }
   }
   if (!defined $args{'-indent'} || $args{'-indent'} =~ m/\D/xms)
   {
      $args{'-indent'} = 2;
   }

   return join q{}, $self->_to_string(%args);
}

sub _to_string
{
   my $self = shift;
   my %args = (@_);

   my $level  = $args{'-level'};
   my $indent = defined $level ? q{ } x $args{'-indent'} : q{};
   my $begin  = defined $level ? $indent x $level        : q{};
   my $end    = defined $level ? "\n"                    : q{};

   # open tag
   my @ret = ( $begin, '<', $self->_XML_escape($self->{name}) );

   # attributes
   foreach my $key (sort keys %{ $self->{attributes} })
   {
      push @ret, (
         q{ }, $self->_XML_escape($key), q{=},
         q{"}, $self->_XML_escape($self->{attributes}->{$key}), q{"},
      );
   }

   # Empty tag?
   if (@{ $self->{children} } == 0)
   {
      push @ret, '/>', $end;
   }

   # Body is pure text?
   elsif ($args{'-formatted'} && !$args{'-textformat'}
          && 0 == scalar grep {$_->isa(__PACKAGE__)} @{$self->{children}})
   {
      push @ret, '>';
      push @ret, map { $_->toString() } @{ $self->{children} };
      push @ret, '{name}, '>', $end;
   }

   # Body has elements
   else
   {
      push @ret, '>', $end;
      foreach my $child (@{ $self->{children} })
      {
         if ($child->isa(__PACKAGE__))
         {
            push @ret, $child->_to_string(
               %args, -level => defined $level ? $level+1 : undef,
            );
         }
         else
         {
            push @ret, $begin, $indent, $child->toString(), $end;
         }
      }
      push @ret, $begin, '{name}, '>', $end;
   }

   return @ret;
}

# Private function
sub _XML_escape
{
   my $pkg_or_self = shift;
   my $text        = shift;

   if (!defined $text)
   {
      $text = q{};
   }
   $text =~ s/&/&/gxms;
   $text =~ s/
   $text =~ s/>/>/gxms;
   $text =~ s/\"/"/gxms;
   return $text;
}

# Private function
sub _CDATA_escape
{
   my $pkg_or_self = shift;
   my $text        = shift;

   # Escape illegal "]]>" strings by ending and restarting the CDATA section
   $text =~ s/ ]]> /]]>]]>

   return "";
}

1;
__END__