use strict;

package XML::DOM::Twig;

use XML::DOM;
use Carp;

use vars qw( $VERSION);

$VERSION= "0.02";

package XML::DOM::Node;

use vars qw( %twig_gi);

%twig_gi= ( TEXT_NODE                   , '#PCDATA' ,
            CDATA_SECTION_NODE          , '#CDATA'  ,
            COMMENT_NODE                , '#COMMENT',
            PROCESSING_INSTRUCTION_NODE , '#PI',
            ENTITY_REFERENCE_NODE       , '#ENT',
          );

print STDERR "XML::DOM::Twig loaded\n";

BEGIN
  { # give proper Perl names to those ugly Java methods
    *get_elements_by_tag_name = *getElementsByTagName;
    *doc                      = *getOwnerDocument;
    *sprint                   = *toString;
  }
1;

sub gi
  { my $node= shift;
    my $type= $node->getNodeType;
    if( $type == ELEMENT_NODE)
      { return $node->getTagName; }
    else
      { return 0; }
  }
  
sub parent
  { my( $elt, $cond)= @_;
    do { $elt= $elt->getParentNode; }
      until( !$elt || $elt->elt_matches( $cond));
    return $elt;
  }

sub descendants
  { my( $subtree_root, $cond)= @_;
    my @descendants=(); 
    my $elt= $subtree_root;
      while( $elt= $elt->next_elt( $subtree_root, $cond))
        { push @descendants, $elt; }
    return @descendants;
  }
 
sub text
  { my $elt= shift;
    my $text='';
    foreach ($elt->descendants( TEXT_NODE))
      { $text .= $_->getData; }
    return $text;
  }
  
sub first_child
  { my $node= shift;
    my $cond= shift || '';

    my $child= $node->getFirstChild or return undef;
    return $child if( $child->elt_matches( $cond));
    return $child->next_sibling( $cond);
  }

sub field
  { my( $node, $cond)= @_;
    my $child= $node->first_child( $cond);
    return $child ? $child->text : '';
  }
  
sub last_child
  { my $node= shift;
    my $cond= shift || '';

    my $child= $node->getLastChild or return undef;
    return $child if( $child->elt_matches( $cond));
    return $child->prev_sibling( $cond);
  }

sub next_sibling
  { my $node= shift;
    my $cond= shift || '';

    my $sibling= $node->getNextSibling;
    while( $sibling && !$sibling->elt_matches( $cond)) 
      { $sibling= $sibling->getNextSibling; }
    return $sibling;
  }

sub prev_sibling
  { my $node= shift;
    my $cond= shift || '';

    my $sibling= $node->getPreviousSibling;
    while( $sibling && !$sibling->elt_matches( $cond)) 
      { $sibling= $sibling->getPreviousSibling; }
    return $sibling;
  }

sub set_atts
  { my( $elt, $atts)= @_;
    foreach my $att (sort keys %$atts)
      { $elt->setAttribute( $att, $atts->{$att}); }
  }      

sub set_content
  { my $elt= shift;

    my $dom; # used to create new text nodes

    foreach my $item (@_)
      { if( ref $item eq 'XML::DOM::Element')
         { $elt->appendChild( $item); }
       else
         { $dom ||= $elt->getOwnerDocument; # get it once and cache it
           $elt->appendChild( $dom->createTextNode( $item)); 
         }
      }
    return $elt;
  }

sub paste
  { my $elt= shift;
    my $position= ref $_[0] ? 'first_child': shift;
    my $ref_elt= shift;

    if( $position eq 'first_child')
      { my $first_child= $ref_elt->getFirstChild;
        $ref_elt->insertBefore( $elt, $first_child);
      }
    elsif( $position eq 'last_child')
      { $ref_elt->appendChild( $elt); 
      }
    elsif( $position eq 'before')
      { my $parent= $ref_elt->getParentNode; 
        $parent->insertBefore( $elt, $ref_elt);
      }
    elsif( $position eq 'after')
      { my $parent= $ref_elt->getParentNode;
        my $next_sibling= $ref_elt->getNextSibling;
        if( $next_sibling)
          { $parent->insertBefore( $elt, $next_sibling); }
        else
          { $parent->appendChild( $elt); }
      }
    return $elt;
  }

sub cut
  { my $elt= shift;
    my $parent= $elt->getParentNode or croak "cannot cut a root";
    $parent->removeChild( $elt);
  }
  
sub children
  { my( $elt, $cond)= @_;
    my @children;
    my $children_nb=0;
    my $child= $elt->first_child( $cond) or return ();
    wantarray ? push @children, $child : $children_nb++;
    while( $child= $child->next_elt( $cond))
      { wantarray ? push @children, $child : $children_nb++; }
    return wantarray ? @children : $children_nb;
  }
    
    
# kinda counter-intuitive actually:
# the next element is found by looking for the next open tag after from the
# current one, which is the first child, if it exists, or the next sibling
# or the first next sibling of an ancestor
# optional arguments are: 
#   - $subtree_root: a reference to an element, when the next element is not 
#                    within $subtree_root anymore then next_elt returns undef
#   - $gi: a gi, next_elt returns the next element of this gi
                 
sub next_elt
  { my $elt= shift;
    my $subtree_root= 0;
    $subtree_root= shift if( UNIVERSAL::isa( $_[0], 'XML::DOM::Node'));
    my $cond= shift;
    my $next_elt;
    do
      { if( $elt->first_child)
          { # simplest case: the elt has a child
            $next_elt= $elt->first_child;
          }
        elsif( $elt->next_sibling) 
          { # no child but a next sibling (just check we stay within the subtree)
          
            # case where elt is subtree_root, is empty and has a sibling
            return undef if( $subtree_root && ($subtree_root == $elt));
            
            $next_elt= $elt->next_sibling;
          }
        else
          { # case where the element has no child and no next sibling:
            # get the first next sibling of an ancestor, checking subtree_root 
          
            # case where elt is subtree_root, is empty and has no sibling
            return undef if( $subtree_root && ($subtree_root == $elt));
             
            # backtrack until we find a parent with a next sibling
            $next_elt= $elt->parent || return undef;
            until( $next_elt->next_sibling)
              { return undef if( $subtree_root && ($subtree_root == $next_elt));
                $next_elt= $next_elt->parent || return undef;
              }
            return undef if( $subtree_root && ($subtree_root == $next_elt)); 
            $next_elt= $next_elt->next_sibling;   
          }  
	  $elt= $next_elt;                   # just in case we need to loop
	} until( $elt->elt_matches( $cond));
	
      return $next_elt;
      }

# counter-intuitive too:
# the previous element is found by looking
# for the first open tag backwards from the current one
# it's the last descendant of the previous sibling 
# if it exists, otherwise it's simply the parent
sub prev_elt
  { my $elt= shift;
    my $cond= shift;
    # get prev elt
    my $prev_elt;
    do
      { if( $prev_elt= $elt->prev_sibling)
          { while( $prev_elt->last_child)
              { $prev_elt= $prev_elt->last_child; }
          }
        else
          { $prev_elt= $elt->parent || return; }
        $elt= $prev_elt;     # in case we need to loop 
      } until( $elt->elt_matches( $cond));

    return $prev_elt;
  }



  
# returns the element if it matches the condition, 0 otherwise
# the condition can be:
# - an element type: a number such as ELEMENT_NODE
# - an element gi:   a string such as 'p'
# - a regexp:        a regexp applied to the element gi
# - a code ref:      a piece of code that gets passed the element as argument
sub elt_matches
  { my( $elt, $cond)= @_;
    return $elt unless $cond;
    unless( ref $cond)
      { return $elt if( $elt->getNodeType eq $cond);
        return $elt if( $elt->gi eq $cond);
      }
    elsif( UNIVERSAL::isa( $cond, 'Regexp'))
      { return $elt if( $elt->gi=~ $cond); }
    elsif( UNIVERSAL::isa( $cond, 'CODE'))
      { return $elt if( $cond->($elt)); }
  }

# used by get_xpath: parses the xpath expression and generates a sub that performs the
# search
sub install_xpath
  { my( $xpath_exp, $type)= @_;
    my $original_exp= $xpath_exp;
    my $sub= 'my $elt= shift; my @results=();';
    
    # grab the root if expression starts with a /
    if( $xpath_exp=~ s{^/}{})
      { $sub .= '@results= ($elt->doc);'; }
    elsif( $xpath_exp=~ s{^\./}{})
      { $sub .= '@results= ($elt);'; }
    else
      { $sub .= '@results= ($elt);'; }

    while( $xpath_exp=~ s{(/?)([^/]+)(/|$)}{}) #
      { my $wildcard= $1;
        my $sub_exp= $2;
        
        # grab a parent
        if( $sub_exp eq '..')
          { croak "error in xpath expression $original_exp" if( $wildcard);
            $sub .= '@results= map { $_->parent} @results;';
          }
        # grab children
        elsif( $sub_exp=~ m{([^\[]+)\s*               # * or a gi    ($1)
                       (?:\[([^\]]*))?\s*}xs)         # optional condition ($2)
          { my $gi= $1 unless( $1 eq '*');
            my $cond= $2; 
            if( $cond) { $cond=~ s{^\s*}{}; $cond=~ s{\s*$}{}; }
            my $function;
            

            # "special" conditions, that return just one element
            if( $cond && ($cond =~ m{^((-\s*)?\d+)$}) )
              { my $offset= $1;
	        $offset-- if( $offset > 0);
                $function=  $wildcard ? "next_n_elt( $offset, '$gi')" 
                                      : "child( $offset, '$gi')";
                $sub .= "\@results= map { \$_->$function } \@results;"
              }
            elsif( $cond && ($cond =~ m{^last\s*\(\s*\)$}) )
              { croak "error in xpath expression $original_exp, cant use // and last()"
                  if( $wildcard);
                 $sub .= "\@results= map { \$_->last_sibling( '$gi') } \@results;";
              }
            else
              { # go down and get the children or descendants
                unless ( defined $gi)
                  { if( $wildcard)
                      { $sub .= '@results= map { $_->descendants  } @results;' }
                    else
                      { $sub .= '@results= map { $_->children } @results;'; }
                  }
                else
                  { if( $wildcard)
                      { $sub .= "\@results= map { \$_->descendants( '$gi')  } \@results;";  }            
                    else
                      { $sub .= "\@results= map { \$_->children( '$gi')  } \@results;"; }
                  } 
                # now filter using the condition
                if( $cond)
                  { my $op='';
                    my $test="";
                    do
                      { if( $op)
                          { $cond=~ s{^\s*$op\s*}{};
                            $op= lc( $op);
                            $test .= $op;
                          }
                      
                       if( $cond =~ s{^string\(\s*\)\s*=\s*((['"]).*?\2)\s*}{})  # string()="string" cond
                          { $test .= "\$_->text eq $1"; 
                          }
                       elsif( $cond =~ s{^string\(\s*\)\s*=~\s*/([^/]*(\\/[^/]*)*)\s*}{})  # string()=~/regex/ cond
                          { $test .= "\$_->text=~/$1/"; 
                          }
                       elsif( $cond=~ s{^@([^=\s]+)\s*=\s*(["'])(.*?)\2}{})  # @att="val" cond
                          { $test .= "((defined \$_->att(\"$1\"))  && (\$_->att( \"$1\" ) eq \"$3\"))";
                          }
                       elsif( $cond=~ s{^@([\w:-]+)}{})                      # @att cond
                          { $test .= "(defined \$_->att(\"$1\"))";
                          }
                       } while( ($op)=($cond=~ m{^\s*(and|or)\s*}i));
                     croak "error in xpath expression $original_exp " if( $cond);
                     $sub .= "\@results= grep { $test } \@results;";
                   }
              }
          }
        else
          { croak "error in xpath expression $original_exp around $sub_exp"; }
      }
    $sub .= "return \@results; ";
    #warn "installing $_[0] => $sub\n\n";
    my $s= eval "sub { $sub }";
    return( $s); 
   }
        
{ # extremely elaborate caching mechanism
  my %xpath; # xpath_expression => subroutine_code;  
  sub get_xpath
    { my( $elt, $xpath_exp, $offset)= @_;
      my $sub= ($xpath{$xpath_exp} ||= install_xpath( $xpath_exp));
      return $sub->( $elt) unless( defined $offset); 
      my @res= $sub->( $elt);
      return $res[$offset];
    }
1; # last BEGIN block in the module
}

sub prefix
  { my ($elt, $prefix, $option)= @_;
    if( $elt->getNodeType == TEXT_NODE)
      { # just add to the element text
	$elt->insertData( 0, $prefix); }
    elsif( $elt->first_child && ($elt->first_child->getNodeType == TEXT_NODE) )
      { $elt->first_child->insertData( 0, $prefix); }
    else
      { my $new_elt= new XML::DOM::CharacterData;
        $new_elt->setData( $prefix);
        $new_elt->paste( $elt);
      }
  }

  
package XML::DOM::Element;
  BEGIN { *att = *getAttribute;
          *get_attribute= *getAttribute;
	  1;
	}

	
package XML::DOM::Document;

BEGIN
  { # aliases
    *root          = *getDocumentElement;
  }

sub new_elt
  { my $dom    = shift; 
    my $gi     = shift;
    my $atts   = shift if(   (ref $_[0] eq 'HASH') 
                          || (ref $_[0] eq 'XML::DOM::NamedNodeMap')
                         );
    my $elt= $dom->createElement( $gi);
    $elt->set_atts( $atts) if( $atts);
    $elt->set_content( @_) if(@_);

    return $elt;
  }

# return a list with just the root
# if an argument (gi) is given then return undef unless the root'd gi matches
sub children
  { my( $doc, $cond)= @_;
    my $root= $doc->root;
    if( $cond && $root->elt_matches( $cond) )
      { return ($root); }
    else
      { return (); }
  }



sub descendants
  { my( $dom, $cond)= @_;
    my $root= $dom->root;
    if( $root->elt_matches( $cond) )
      { return ($root, $root->descendants( $cond)); }
    else
      { return ( $root->descendants( $cond)); }
  }

sub get_xpath
  { my $doc= shift;
    $doc->root->get_xpath( @_);
  }

__END__

=head1 NAME

XML::DOM::Twig - a perl module that adds an XML::Twig like interface to XML::DOM

=head1 SYNOPSYS

  use XML::DOM;
  use TwigDOM;

  my $parser = new XML::DOM::Parser;
  my $doc = $parser->parsefile( "doc.xml");

  my $root= $doc->root;               # the DOM method is getDocumentElement
  my $para= $root->next_elt( 'para'); # adds a condition to DOM's getNextSibling

=head1 DESCRIPTION

The DOM is a standard interface to XML documents, but it is very low-level,
not to mention down right ugly, at least as implemented in XML::DOM. 

XML::DOM::Twig adds nicer (and more perlish) method names, plus a whole slew of
extra methods,most of them straight out of XML::Twig, that makes it easier
and safer to use it.

XML::DOM::Twig navigation functions for example accept an extra condition that 
makes it easy to specify what the tag of the next element should be, instead of
either hoping that DOM methods will return the right one (they won't!) or 
having to write a similar function yourself.

=head1 METHODS

=head2 XML::DOM::Node

=over 4

=item * aliases

XML::DOM::Twig creates aliases for a number of XML::DOM methods:

    get_elements_by_tag_name  =  getElementsByTagName;
    doc                       =  getOwnerDocument;
    att                       =  getAttribute;
    get_attribute             =  getAttribute;
    sprint                    =  toString;


=item * gi

returns the gi (tag) of an element if the node is of type ELEMENT_NODE or 0

=item * parent ($opt_cond)

returns the parent, or the first (innermost) parent that passes the condition
the condition can be either a node type, or a gi, or a regexp (applied to the
gi) or a code ref (applied to the element)

=item * descendants ($opt_cond)

Returns the list of all descendants (optionally whose gi) of the element
This is the equivalent of the getElementsByTagName of the DOM

=item * text

Returns a string consisting of all the PCDATA and CDATA in an element, 
without any tags. The text is not XML-escaped: base entities such as &
and < are not escaped.

=item * first_child   ($optional_cond)

Returns the first child of the element, or the first child matching the L<cond>

=item * field ($optional_cond)

Returns the text of the first child of the element, or the first child
If there is no first_child then returns ''. This avoids getting the
child, checking for its existence then getting the text for trivial cases.

=item * last_child ($optional_gi)

Returns the last child of the element, or the last child whose gi is 
$optional_gi (ie the last of the element children whose gi matches).

=item * next_sibling($optional_cond)

Returns the next sibling of the element, or the first one matching L<cond>. 

=item * prev_sibling($optional_cond)

Returns the previous sibling of the element, or the previous sibling matching
L<cond>


=item * set_atts ( $optional_atts, @list_of_elt_and_strings)

Sets the content for the element, from a list of strings and
elements.  Cuts all the element children, then pastes the list
elements as the children.  This method will create a PCDATA element
for any strings in the list.

The optional_atts argument is the ref of a hash of attributes. If this
argument is used then the previous attributes are deleted, otherwise they
are left untouched. 

=item * set_content


=item * paste       ($optional_position, $ref)

Pastes a (previously cut or newly generated) element. Dies if the element
already belongs to a tree.

The optional position element can be:

=over 4

=item first_child (default)

The element is pasted as the first child of the element object this
method is called on.

=item last_child

The element is pasted as the last child of the element object this
method is called on.

=item before

The element is pasted before the element object, as its previous
sibling.

=item after

The element is pasted after the element object, as its next sibling.

=item within

In this case an extra argument, $offset, should be supplied. The element
will be pasted in the reference element (or in its first text child) at the
given offset. To achieve this the reference element will be split at the 
offset.

=back

=item * cut

Cuts the element from the tree. The element still exists, it can be copied
or pasted somewhere else, it is just not attached to the tree anymore.


=item * children($optional_cond)

Returns the list of children (optionally which matches L<cond>) of the
element. The list is in document order.

=item * next_elt($optional_elt, $optional_cond)

Returns the next elt (optionally matching L<cond>) of the element. This is 
defined as the next element which opens after the current element opens.
Which usually means the first child of the element.
Counter-intuitive as it might look this allows you to loop through the
whole document by starting from the root.

The $optional_elt is the root of a subtree. When the next_elt is out of the
subtree then the method returns undef. You can then walk a sub tree with:

  my $elt= $subtree_root;
  while( $elt= $elt->next_elt( $subtree_root)
    { # insert processing code here
    }

=item * prev_elt ($optional_cond)

Returns the previous elt (optionally matching L<cond>) of the
element. This is the first element which opens before the current one.
It is usually either the last descendant of the previous sibling or
simply the parent

=item * get_xpath ($xpath_like_expression, $optional_offset)

Returns a list of elements satisfying the $xpath_like_expression. 

A subset of the XPATH abbreviated syntax is covered:

  gi
  gi[1] (or any other positive number)
  gi[last()]
  gi[@att] (the attribute exists for the element)
  gi[@att="val"]
  gi[att1="val1" and att2="val2"]
  gi[att1="val1" or att2="val2"]
  gi[string()="toto"] (returns gi elements which text is toto)
  gi[string()=~/regexp/] (returns gi elements which text matches regexp)
  expressions can start with / (search starts at the document root)
  expressions can start with . (search starts at the current element, optional)
  // can be used to get all descendants instead of just direct children
  * matches any gi
  
So the following examples from the XPATH recommendation 
(http://www.w3.org/TR/xpath.html#path-abbrev) work:

  para selects the para element children of the context node
  * selects all element children of the context node
  para[1] selects the first para child of the context node
  para[last()] selects the last para child of the context node
  */para selects all para grandchildren of the context node
  /doc/chapter[5]/section[2] selects the second section of the fifth chapter of the doc 
  chapter//para selects the para element descendants of the chapter element children of the context node
  //para selects all the para descendants of the document root and thus selects all para elements in the same document as the
             context node
  //olist/item selects all the item elements in the same document as the context node that have an olist parent
  .//para selects the para element descendants of the context node
  .. selects the parent of the context node
  para[@type="warning"] selects all para children of the context node that have a type attribute with value warning 
  employee[@secretary and @assistant] selects all the employee children of the context node that have both a secretary attribute and
             an assistant attribute


The elements will be returned in the document order.

If $optional_offset is used then only one element will be returned, the one 
with the appropriate offset in the list, starting at 0

Quoting and interpolating variables can be a pain when the Perl syntax and the 
XPATH syntax collide, so here are some more examples to get you started:

  my $p1= "p1";
  my $p2= "p2";
  my @res= $t->get_xpath( "p[string( '$p1') or string( '$p2')]");

  my $a= "a1";
  my @res= $t->get_xpath( "//*[@att=\"$a\"]);

  my $val= "a1";
  my $exp= "//p[ \@att='$val']"; # you need to use \@ or you will get a warning
  my @res= $t->get_xpath( $exp);

XML::DOM::Twig does not provide full XPATH support. If that's what you want 
then look no further than the XML::XPath module on CPAN.

=item * find_nodes

alias to L<get_xpath>

=back

=head3 cond

Most of the navigation functions accept a condition as an optional argument
The first element (or all elements for C<L<children>> or C<L<ancestors>>) that
passes the condition is returned.

The condition can be 

=over 4

=item #ELT

return a "real" element (not a PCDATA, CDATA, comment or pi element) 

=item #TEXT

return a PCDATA or CDATA element

=item string

return an element whose gi is equal to the string

=item regular expression

return an element whose gi matches the regexp. The regexp has to be created 
with C<qr//> (hence this is available only on perl 5.005 and above)

=item code reference

applies the code, passing the current element as argument, if the code returns
true then the element is returned, if it returns false then the code is applied
to the next candidate.

=item * prefix

adds a prefix to an element

=back


=head2 XML::DOM::Document

=over 4

=item * new_elt

=item * children

=item * descendants

=item * get_xpath

=back

=head1 AUTHOR

Michel Rodriguez <m.v.rodriguez@ieee.org>

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

Bug reports and comments to m.v.rodriguez@ieee.org.

The XML::DOM::Twig web site is  http://www.xmltwig.com/domtwig/

=head1 SEE ALSO

XML::Parser
XML::DOM
XML::Twig

The XML::Twig page is at http://www.xmltwig.com/xmltwig/
It includes examples and a tutorial at 
  http://www.xmltwig.com/xmltwig/tutorial/index.html


=cut

