File Coverage

blib/lib/XML/XSH2/XPathToXML.pm

Criterion	Covered	Total	%
statement	80	199	40.2
branch	38	134	28.3
condition	8	40	20.0
subroutine	10	18	55.5
pod	10	10	100.0
total	146	401	36.4

package XML::XSH2::XPathToXML;
###
#
# Name: XML::XSH2::XPathToXML
# Version: 0.05
# Description: Parses a list of XPath/value pairs and returns an XML::LibXML note-tree.
# Original author: Kurt George Gjerde
# Extended by Petr Pajas
# Copyright: InterMedia, University of Bergen (2002)
# Licence: Same as Perl
#
###

### POD at bottom.


###

use XML::LibXML;
use strict;
no warnings qw(uninitialized);

use vars qw($VERSION);
$VERSION = '0.05';

my $PACKAGE = __PACKAGE__;

our ($QUOT,$NAMECHAR,$FIRSTNAMECHAR,$NAME,$STEP,$LAST_STEP,$FILTER,$PREDICATE,$AXIS);

# regexps to parse XPath steps

$NAMECHAR = '[-_.[:alnum:]]';
$FIRSTNAMECHAR = '[-_.[:alpha:]]';
$NAME = "(?:${FIRSTNAMECHAR}${NAMECHAR}*(?::${FIRSTNAMECHAR}${NAMECHAR}+)*)";

$QUOT = q{(?:'[^']*'|"[^"]*")};
$PREDICATE = qr/
  (?:
     (?> [^][()"']* )   # non-parens without backtracking
     |
     '[^']*' | "[^"]*"  # quotes
     |
     \[
       (??{$PREDICATE}) # matching square brackets
     \]
     |
     \(
       (??{$PREDICATE}) # matching round brackets
     \)
   )*
/x;

$FILTER = qr/(?:\[$PREDICATE\])/;

$AXIS=qr{(?:(?:following-sibling|following|preceding|preceding-sibling|parent|ancestor|ancestor-or-self|descendant|self|descendant-or-self|child|namespace)::)?};
$STEP = qr{(?:(?:^|/)${AXIS}${NAME}${FILTER}*)};
$LAST_STEP = qr{(?:(?:^|/)(?:\@${NAME}|${AXIS}(?:${NAME}|comment[(][)]|text[(][)]|processing-instruction[(](?:\s*"${NAME}"\s*|\s*'${NAME}'\s*)[)]))${FILTER}*)};

### NEW
#
sub new {
  my ($class, %args) = @_;
  my $self = \%args;
  bless $self, $class;

  $self->{version} ||= '1.0';
  $self->{debug} ||= 0;
  $self->{maxAutoSiblings} = 256 if not defined $self->{maxAutoSiblings};

  $self->init();

  return $self;
}


### CLOSE
#
sub close {
  my $self = shift;
  undef $self->{tree};
  undef $self->{node};
  undef $self->{doc};
}


### INIT
#
sub init {
  my $self = shift;
  unless ($self->{doc}) {
    if (ref($self->{node})) {
      $self->{doc} = $self->{node}->ownerDocument;
    } else {
      $self->{doc} = XML::LibXML::Document->createDocument( $self->{version}, $self->{encoding} );
      $self->{doc}->setDocumentElement( $self->{doc}->createElement('root') );
    }
  }
  $self->{node} ||= $self->{doc};
  $self->{tree} = {};
}


### RESET
#
sub setContextNode {
  my ($self,$node) = @_;
  undef $self->{tree};
  unless (ref($node)) {
    if ($self->{XPathContext}) {
      $node=$self->{XPathContext}->find($node)->get_node(1);
    } else {
      $node=$self->{node}->find($node)->get_node(1);
    }
  }
  if ($node) {
    $self->{node} = $node;
    $self->{doc} = $node->ownerDocument;
  } else {
    die "[$PACKAGE] Context node doesn't exist.\n";
  }
}


### RESET
#
sub reset {
  my ($self,%args) = @_;
  $self->close;
  $self->init(%args);
}


### GET IT
#
sub contextNode { shift->{node} }

sub document { shift->{doc} }

sub documentElement { shift->{doc}->documentElement }


### PARSE
#
sub parse {
  my ($self, $data, $value) = @_;

  if (ref($data) eq 'HASH') {
    foreach my $xpath (sort keys %{$data}) {
      print "$xpath\n" if $self->{debug};
      $self->createNode( $xpath, $data->{$xpath} );
    }
  } elsif (ref($data) eq 'ARRAY') {
    # preserve order
    die "[$PACKAGE] Array must have even number of elements.\n" if (@$data % 2);
    for (my $i=0; $i<@$data; $i+=2) {
      print "$data->[$i]\n" if $self->{debug};
      $self->createNode( $data->[$i], $data->[$i+1] );
    }
  } else {
    $self->createNode( $data, $value );
  }

  return $self->{doc}->documentElement();
}


### _CREATE NODE
#
# Creates nodes, text nodes and attributes from an xpath and a value.
#
# Returns the node created
#

sub createNode {
  my ($self, $xpath, $value, $context_node) = @_;

  # strip the uninteresting part
  $xpath=~s{^\.\s+/}{};

  # roughly verify that we have an XPath in a supported form:
  die "[$PACKAGE] Can't create nodes based on XPath $xpath\n" unless $xpath =~ m{^(?:\$${NAME}${FILTER}*)?$STEP*$LAST_STEP$};
#  return;

  if ($xpath=~s{^/}{}) {
    # start from the document level
    $self->_createSteps($self->{doc},$xpath,$value);
  } else {
    if ($xpath =~ s{^(\$${NAME}${FILTER}*)/}{./}) {
      $context_node = $1;
    }
    # start from the current node
    if ($context_node ne "" and !ref($context_node)) {
      if ($self->{XPathContext}) {
	$context_node=$self->{XPathContext}->find($context_node)->get_node(1);
      } else {
	$context_node=$self->{node}->find($context_node)->get_node(1);
      }
      die "[$PACKAGE] Context node doesn't exist.\n" unless ($context_node);
    } else {
      $context_node ||= $self->{node};
    }
    $self->_createSteps($context_node,$xpath,$value);
  }
}

sub _lookup_namespace {
  my ($self,$node,$name)=@_;
  if ($name=~s/^(${NAMECHAR}+)://) {
    my $prefix = $1;
    my $uri = $node->lookupNamespaceURI($prefix);
    if (!defined($uri) and $self->{XPathContext} and
	    UNIVERSAL::can($self->{XPathContext},'lookupNs')) {
      $uri = $self->{XPathContext}->lookupNs($prefix)
    }
    if (!defined($uri) and ref($self->{namespaces})) {
      $uri = $self->{namespaces}->{ $prefix };
    }
    if (!defined($uri)) {
      warn "Couldn't find namespace URI for the element ${prefix}:${node}!\n";
      return ($prefix.':'.$name,undef);
    } else {
      # find the best suitable prefix
      my $real_prefix = $node->lookupNamespacePrefix( $uri );
      if ($real_prefix eq "" and !defined($node->lookupNamespaceURI( undef ))) {
	$real_prefix = $prefix;
      }
      return (($real_prefix ne "") ? $real_prefix.':'.$name : $name , $uri);
    }
  } else {
    return ($name,undef);
  }
}

sub _insertNode {
  my ( $self, $axis, $node, $next ) = @_;
  if ($axis =~ /^$|^child::|^descendant(?:-or-self)?::/) {
    $node->appendChild( $next );
  } elsif ($axis =~ /^(following(?:-sibling)?)::/) {
    my $parent = $node->parentNode;
    die "Can't create axis $1 on a document node" unless $parent;
    $parent->insertAfter( $next, $node );
  } elsif ($axis =~ /^(preceding(?:-sibling)?)::/) {
    my $parent = $node->parentNode;
    die "Can't create axis $1 on a document node" unless $parent;
    $parent->insertBefore( $next, $node );
  } elsif ($axis =~ /^(parent|ancestor|ancestor-or-self|self|namespace)::/) {
    die "Can't create axis $1";
  }
}

sub _createSteps {
  my ($self,$node,$xpath,$value)=@_;

  while ($xpath ne "") {
  # get the first step
    my $step = $xpath;
    my $rest;
    if ($step =~ s{^(.*?)\/(.*)$}{$1}) {
      $rest = $2;
    }

    print "$xpath : Processing step: $step (remains $rest)\n" if $self->{debug};

    my $next = $self->{XPathContext} ?
      $self->{XPathContext}->find($step,$node)->get_node(1) :
      $node->find($step)->get_node(1);

    unless ($next) {
      # auto-create the node(s) implied by the step

      if ($step =~ /^(?:@|attribute::)($NAME)/) {
	my $name = $1;
	if ($rest eq "") {
	  print "$xpath : auto-creating attribute $name for $step\n" if $self->{debug};
	  my ($real_name,$uri) = $self->_lookup_namespace($node,$name);
	  if (defined($uri) and $uri ne "") {
	    $node->setAttributeNS($uri,$name,$value);
	    return $node->getAttributeNodeNS($uri,$name);
	  } else {
	    $node->setAttribute($name,$value);
	    return $node->getAttributeNode($name);
	  }
	} else {
	  die "[$PACKAGE] XPath steps follow after an attribute: $step/$rest\n";
	}
      } elsif ($step =~ /^($AXIS)text\(\)/) {
	my $axis = $1;
	if ($rest eq "") {
	  print "$xpath : auto-creating text() for $step\n" if $self->{debug};
	  $next = $self->{doc}->createTextNode($value);
	  $self->_insertNode( $axis, $node, $next );
	  return $next;
	} else {
	  die "[$PACKAGE] XPath steps follow after a text(): $step/$rest\n";
	}
      } elsif ($step  =~ /^($AXIS)comment\(\)/) {
	my $axis = $1;
	if ($rest eq "") {
	  print "$xpath : auto-creating comment  for $step\n" if $self->{debug};
	  $next = $self->{doc}->createComment($value);
	  $self->_insertNode( $axis, $node, $next );
	  return $next;
	} else {
	  die "[$PACKAGE] XPath steps follow after a text(): $step/$rest\n";
	}
      } elsif ($step  =~ /^($AXIS)processing-instruction\((${PREDICATE})\)/o) {
	my $axis = $1;
	my $name = $2;
	if ($name=~/^(?:\s*'([^']*)'|"([^"]*)"\s*)$/) {
	  $name=$1.$2;
	  if ($rest eq "") {
	    print "$xpath : auto-creating comment  for $step\n" if $self->{debug};
	    $next = $self->{doc}->createProcessingInstruction($name,$value);
	    $self->_insertNode( $axis, $node, $next );
	    return $next;
	  } else {
	    die "[$PACKAGE] XPath steps follow after a processing-instruction(): $step/$rest\n";
	  }
	} else {
	  die "[$PACKAGE] Can't auto-create PI as specified ($name), use processing-instruction('name')\n";
	}
      } else {
	my ($name,$axis);
	if ($step =~ /^($AXIS)($NAME)(?!\()/) {
	  $axis = $1;
	  $name = $2;
	};
	if ($name eq "") {
	  die "[$PACKAGE] Can't determine element name from step $step\n";
	}
	my @auto;
	do {{
	  print "$xpath : auto-creating element $name for $step\n" if $self->{debug};
	  if ($self->{maxAutoSiblings} && @auto>$self->{maxAutoSiblings}) {
	    # unlink all added siblings
	    # print STDERR $self->{doc}->toString(1),"\n @auto\n";
	    $_->unlinkNode for @auto;
	    die "[$PACKAGE] Max automatic creation of siblings overflow ($self->{maxAutoSiblings}) for '$xpath', step '$step'!\n";
	  }
	  my ($real_name,$uri) = $self->_lookup_namespace($node,$name);
	  if (defined($uri) and $uri ne "") {
	    $next = $self->{doc}->createElementNS($uri,$real_name);
	  } else {
	    $next = $self->{doc}->createElement($real_name);
	  }
	  if ($node == $self->{doc}) {
	    $node->setDocumentElement( $next );
	    # iterating won't help here
	    last;
	  } else {
	    $self->_insertNode( $axis, $node, $next );
	  }
	  push @auto,$next;

	  $next = $self->{XPathContext} ?
	    $self->{XPathContext}->find($step,$node)->get_node(1) :
	    $node->find($step)->get_node(1);
	}} while (!$next);
      }
    }
    $xpath = $rest;
    $node = $next;
  };

  if ($node) {
    print "Setting value for $xpath\n" if $self->{debug};
    if ($node->nodeType == XML::LibXML::XML_ATTRIBUTE_NODE()) {
      $node->setValue($value);
    } elsif ($node->nodeType != XML::LibXML::XML_ELEMENT_NODE()) {
      $node->setData($value);
    } else {
      $node->removeChildNodes() if $node->hasChildNodes;
      if (ref($value) and UNIVERSAL::isa($value,'XML::LibXML::Node')) {
	$node->appendChild( $value );
      } else {
	$node->appendTextNode($value) if $value ne "";
      }
    }
  } else {
    warn "No node for XPath ($xpath)\n";
  }
  return $node;
}

###
#
# The following method use a hash to store all the xpaths and their nodes.
# Locating a node is purely based on looking up its xpath the way it's been
# written. Thus 'somenode[1]' and 'somenode[position()=1]' will be treated as
# two different nodes!
#
# Using proper xpath doc->find to retrieve nodes instead of the hash will
# eliminate this problem.
#
# Anyway:
#   - if you have a 'node[1]' and a 'node[3]' a 2nd node will not be
#     created inbetween.
#   - if you have a 'node[position()=1]' and a 'node[2]' the nodes will
#     be reversed in the doc (all xpaths are created in alphabetical order).
#
# ALL OF THESE PROBLEMS HAVE BEEN FIXED IN THE createNode METHOD ABOVE!
#
#
sub _createNode_simple {
  my ($self, $xpath, $value) = @_;

  my $name = $xpath;
  $name =~ s{^.*\/(.*)$}{$1};
  $name =~ s{\[.*\]$}{};

  my $parent = $xpath;
  $parent =~ s{^(.*)\/.*$}{$1};

  if ($parent && !defined $self->{tree}->{$parent}) {
    $self->_createNode_simple($parent, undef);
  }

  # Attribute
  if ($name =~ /^@/) {
    print "   addAttribute: $xpath\n" if $self->{debug};
    $self->{tree}->{$parent}->setAttribute($name,$value);
  }
  # Element
  else {
    print "  createElement: $xpath\n" if $self->{debug};

    $self->{tree}->{$xpath} = $self->{doc}->createElement($name);

    if ($parent) {
      $self->{tree}->{$parent}->appendChild( $self->{tree}->{$xpath} );
    } else {
      $self->{doc}->setDocumentElement( $self->{tree}->{$xpath} );
    }

    $self->{tree}->{$xpath}->appendTextNode($value) if $value;
  }

  return undef;
}


###########
1;


__END__