[Summary view] [Print] [Text view]

   1  # $Id: Node.pm,v 1.13 2002/12/26 17:24:50 matt Exp $
   2  
   3  package XML::XPath::Node;
   4  
   5  use strict;
   6  use vars qw(@ISA @EXPORT $AUTOLOAD %EXPORT_TAGS @EXPORT_OK);
   7  use Exporter;
   8  use Carp;
   9  @ISA = ('Exporter');
  10  
  11  sub UNKNOWN_NODE () {0;}
  12  sub ELEMENT_NODE () {1;}
  13  sub ATTRIBUTE_NODE () {2;}
  14  sub TEXT_NODE () {3;}
  15  sub CDATA_SECTION_NODE () {4;}
  16  sub ENTITY_REFERENCE_NODE () {5;}
  17  sub ENTITY_NODE () {6;}
  18  sub PROCESSING_INSTRUCTION_NODE () {7;}
  19  sub COMMENT_NODE () {8;}
  20  sub DOCUMENT_NODE () {9;}
  21  sub DOCUMENT_TYPE_NODE () {10;}
  22  sub DOCUMENT_FRAGMENT_NODE () {11;}
  23  sub NOTATION_NODE () {12;}
  24  
  25  # Non core DOM stuff
  26  sub ELEMENT_DECL_NODE () {13;}
  27  sub ATT_DEF_NODE () {14;}
  28  sub XML_DECL_NODE () {15;}
  29  sub ATTLIST_DECL_NODE () {16;}
  30  sub NAMESPACE_NODE () {17;}
  31  
  32  # per-node constants
  33  
  34  # All
  35  sub node_parent () { 0; }
  36  sub node_pos () { 1; }
  37  sub node_global_pos () { 2; }
  38  
  39  # Element
  40  sub node_prefix () { 3; }
  41  sub node_children () { 4; }
  42  sub node_name () { 5; }
  43  sub node_attribs () { 6; }
  44  sub node_namespaces () { 7; }
  45  sub node_ids () { 8; }
  46  
  47  # Char
  48  sub node_text () { 3; }
  49  
  50  # PI
  51  sub node_target () { 3; }
  52  sub node_data () { 4; }
  53  
  54  # Comment
  55  sub node_comment () { 3; }
  56  
  57  # Attribute
  58  # sub node_prefix () { 3; }
  59  sub node_key () { 4; }
  60  sub node_value () { 5; }
  61  
  62  # Namespaces
  63  # sub node_prefix () { 3; }
  64  sub node_expanded () { 4; }
  65  
  66  @EXPORT = qw(
  67      UNKNOWN_NODE
  68      ELEMENT_NODE
  69      ATTRIBUTE_NODE
  70      TEXT_NODE
  71      CDATA_SECTION_NODE
  72      ENTITY_REFERENCE_NODE
  73      ENTITY_NODE
  74      PROCESSING_INSTRUCTION_NODE
  75      COMMENT_NODE
  76      DOCUMENT_NODE
  77      DOCUMENT_TYPE_NODE
  78      DOCUMENT_FRAGMENT_NODE
  79      NOTATION_NODE
  80      ELEMENT_DECL_NODE
  81      ATT_DEF_NODE
  82      XML_DECL_NODE
  83      ATTLIST_DECL_NODE
  84      NAMESPACE_NODE
  85      );
  86  
  87  @EXPORT_OK = qw(
  88              node_parent
  89              node_pos
  90              node_global_pos
  91              node_prefix
  92              node_children
  93              node_name
  94              node_attribs
  95              node_namespaces
  96              node_text
  97              node_target
  98              node_data
  99              node_comment
 100              node_key
 101              node_value
 102              node_expanded
 103                          node_ids
 104          );
 105  
 106  %EXPORT_TAGS = (
 107      'node_keys' => [
 108          qw(
 109              node_parent
 110              node_pos
 111              node_global_pos
 112              node_prefix
 113              node_children
 114              node_name
 115              node_attribs
 116              node_namespaces
 117              node_text
 118              node_target
 119              node_data
 120              node_comment
 121              node_key
 122              node_value
 123              node_expanded
 124                          node_ids
 125          ), @EXPORT,
 126      ],
 127  );
 128  
 129  
 130  my $global_pos = 0;
 131  
 132  sub nextPos {
 133      my $class = shift;
 134      return $global_pos += 5;
 135  }
 136  
 137  sub resetPos {
 138      $global_pos = 0;
 139  }
 140  
 141  my %DecodeDefaultEntity =
 142  (
 143   '"' => """,
 144   ">" => ">",
 145   "<" => "&lt;",
 146   "'" => "&apos;",
 147   "&" => "&amp;"
 148  );
 149  
 150  sub XMLescape {
 151      my ($str, $default) = @_;
 152      return undef unless defined $str;
 153      $default ||= '';
 154      
 155      if ($XML::XPath::EncodeUtf8AsEntity) {
 156          $str =~ s/([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)|([$default])|(]]>)/
 157          defined($1) ? XmlUtf8Decode ($1) : 
 158          defined ($2) ? $DecodeDefaultEntity{$2} : "]]&gt;" /egsx;
 159      }
 160      else {
 161          $str =~ s/([$default])|(]]>)/
 162          defined ($1) ? $DecodeDefaultEntity{$1} : ']]&gt;' /gsex;
 163      }
 164  
 165  #?? could there be references that should not be expanded?
 166  # e.g. should not replace &#nn; &#xAF; and &abc;
 167  #    $str =~ s/&(?!($ReName|#[0-9]+|#x[0-9a-fA-F]+);)/&amp;/go;
 168  
 169      $str;
 170  }
 171  
 172  #
 173  # Opposite of XmlUtf8Decode plus it adds prefix "&#" or "&#x" and suffix ";"
 174  # The 2nd parameter ($hex) indicates whether the result is hex encoded or not.
 175  #
 176  sub XmlUtf8Decode
 177  {
 178      my ($str, $hex) = @_;
 179      my $len = length ($str);
 180      my $n;
 181  
 182      if ($len == 2) {
 183          my @n = unpack "C2", $str;
 184          $n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f);
 185      }
 186      elsif ($len == 3) {
 187          my @n = unpack "C3", $str;
 188          $n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) + 
 189              ($n[2] & 0x3f);
 190      }
 191      elsif ($len == 4) {
 192          my @n = unpack "C4", $str;
 193          $n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12) + 
 194              (($n[2] & 0x3f) << 6) + ($n[3] & 0x3f);
 195      }
 196      elsif ($len == 1) {    # just to be complete...
 197          $n = ord ($str);
 198      }
 199      else {
 200          die "bad value [$str] for XmlUtf8Decode";
 201      }
 202      $hex ? sprintf ("&#x%x;", $n) : "&#$n;";
 203  }
 204  
 205  sub new {
 206      my $class = shift;
 207      no strict 'refs';
 208      my $impl = $class . "Impl";
 209      my $this = $impl->new(@_);
 210      if ($XML::XPath::SafeMode) {
 211          return $this;
 212      }
 213      my $self = \$this;
 214      return bless $self, $class;
 215  }
 216  
 217  sub AUTOLOAD {
 218      my $method = $AUTOLOAD;
 219      $method =~ s/.*:://;
 220  #    warn "AUTOLOAD $method!\n";
 221      no strict 'refs';
 222      *{$AUTOLOAD} = sub { 
 223          my $self = shift;
 224          my $olderror = $@; # store previous exceptions
 225          my $obj = eval { $$self };
 226          if ($@) {
 227              if ($@ =~ /Not a SCALAR reference/) {
 228                  croak("No such method $method in " . ref($self));
 229              }
 230              croak $@;
 231          }
 232          if ($obj) {
 233              # make sure $@ propogates if this method call was the result
 234              # of losing scope because of a die().
 235              if ($method =~ /^(DESTROY|del_parent_link)$/) {
 236                  $obj->$method(@_);
 237                  $@ = $olderror if $olderror;
 238                  return;
 239              }
 240              return $obj->$method(@_);
 241          }
 242      };
 243      goto &$AUTOLOAD;
 244  }
 245  
 246  package XML::XPath::NodeImpl;
 247  
 248  use vars qw/@ISA $AUTOLOAD/;
 249  @ISA = ('XML::XPath::Node');
 250  
 251  sub new {
 252      die "Virtual base method";
 253  }
 254  
 255  sub getNodeType {
 256      my $self = shift;
 257      return XML::XPath::Node::UNKNOWN_NODE;
 258  }
 259  
 260  sub isElementNode {}
 261  sub isAttributeNode {}
 262  sub isNamespaceNode {}
 263  sub isTextNode {}
 264  sub isProcessingInstructionNode {}
 265  sub isPINode {}
 266  sub isCommentNode {}
 267  
 268  sub getNodeValue {
 269      return;
 270  }
 271  
 272  sub getValue {
 273      shift->getNodeValue(@_);
 274  }
 275  
 276  sub setNodeValue {
 277      return;
 278  }
 279  
 280  sub setValue {
 281      shift->setNodeValue(@_);
 282  }
 283  
 284  sub getParentNode {
 285      my $self = shift;
 286      return $self->[XML::XPath::Node::node_parent];
 287  }
 288  
 289  sub getRootNode {
 290      my $self = shift;
 291      while (my $parent = $self->getParentNode) {
 292          $self = $parent;
 293      }
 294      return $self;
 295  }
 296  
 297  sub getElementById {
 298      my $self = shift;
 299      my ($id) = @_;
 300  #    warn "getElementById: $id\n";
 301      my $root = $self->getRootNode;
 302      my $node = $root->[XML::XPath::Node::node_ids]{$id};
 303  #    warn "returning node: ", $node->getName, "\n";
 304      return $node;
 305  }
 306  
 307  sub getName { }
 308  sub getData { }
 309  
 310  sub getChildNodes {
 311      return wantarray ? () : [];
 312  }
 313  
 314  sub getChildNode {
 315      return;
 316  }
 317  
 318  sub getAttribute {
 319      return;
 320  }
 321  
 322  sub getAttributes {
 323      return wantarray ? () : [];
 324  }
 325  
 326  sub getAttributeNodes {
 327      shift->getAttributes(@_);
 328  }
 329  
 330  sub getNamespaceNodes {
 331      return wantarray ? () : [];
 332  }
 333  
 334  sub getNamespace {
 335      return;
 336  }
 337  
 338  sub getLocalName {
 339      return;
 340  }
 341  
 342  sub string_value { return; }
 343  
 344  sub get_pos {
 345      my $self = shift;
 346      return $self->[XML::XPath::Node::node_pos];
 347  }
 348  
 349  sub set_pos {
 350      my $self = shift;
 351      $self->[XML::XPath::Node::node_pos] = shift;
 352  }
 353  
 354  sub get_global_pos {
 355      my $self = shift;
 356      return $self->[XML::XPath::Node::node_global_pos];
 357  }
 358  
 359  sub set_global_pos {
 360      my $self = shift;
 361      $self->[XML::XPath::Node::node_global_pos] = shift;
 362  }
 363  
 364  sub renumber {
 365      my $self = shift;
 366      my $search = shift;
 367      my $diff = shift;
 368      
 369      foreach my $node ($self->findnodes($search)) {
 370          $node->set_global_pos(
 371                  $node->get_global_pos + $diff
 372                  );
 373      }
 374  }
 375      
 376  sub insertAfter {
 377      my $self = shift;
 378      my $newnode = shift;
 379      my $posnode = shift;
 380  
 381      my $pos_number = eval { $posnode->[XML::XPath::Node::node_children][-1]->get_global_pos() + 1; };
 382      if (!defined $pos_number) {
 383          $pos_number = $posnode->get_global_pos() + 1;
 384      }
 385      
 386      eval {
 387          if ($pos_number == 
 388                  $posnode->findnodes(
 389                      'following::node()'
 390                      )->get_node(1)->get_global_pos()) {
 391              $posnode->renumber('following::node()', +5);
 392          }
 393      };
 394      
 395      my $pos = $posnode->get_pos;
 396      
 397      $newnode->setParentNode($self);
 398      splice @{$self->[XML::XPath::Node::node_children]}, $pos + 1, 0, $newnode;
 399      
 400      for (my $i = $pos + 1; $i < @{$self->[XML::XPath::Node::node_children]}; $i++) {
 401          $self->[XML::XPath::Node::node_children][$i]->set_pos($i);
 402      }
 403      
 404      $newnode->set_global_pos($pos_number);
 405  }
 406  
 407  sub insertBefore {
 408      my $self = shift;
 409      my $newnode = shift;
 410      my $posnode = shift;
 411      
 412      my $pos_number = ($posnode->getPreviousSibling() || $posnode->getParentNode)->get_global_pos();
 413      if ($pos_number == $posnode->get_global_pos()) {
 414          $posnode->renumber('self::node() | descendant::node() | following::node()', +5);
 415      }
 416      
 417      my $pos = $posnode->get_pos;
 418      
 419      $newnode->setParentNode($self);
 420      splice @{$self->[XML::XPath::Node::node_children]}, $pos, 0, $newnode;
 421      
 422      for (my $i = $pos; $i < @{$self->[XML::XPath::Node::node_children]}; $i++) {
 423          $self->[XML::XPath::Node::node_children][$i]->set_pos($i);
 424      }
 425      
 426      $newnode->set_global_pos($pos_number);
 427  }
 428  
 429  sub getPreviousSibling {
 430      my $self = shift;
 431      my $pos = $self->[XML::XPath::Node::node_pos];
 432      return unless $self->[XML::XPath::Node::node_parent];
 433      return $self->[XML::XPath::Node::node_parent]->getChildNode($pos);
 434  }
 435  
 436  sub getNextSibling {
 437      my $self = shift;
 438      my $pos = $self->[XML::XPath::Node::node_pos];
 439      return unless $self->[XML::XPath::Node::node_parent];
 440      return $self->[XML::XPath::Node::node_parent]->getChildNode($pos + 2);
 441  }
 442  
 443  sub setParentNode {
 444      my $self = shift;
 445      my $parent = shift;
 446  #    warn "SetParent of ", ref($self), " to ", $parent->[XML::XPath::Node::node_name], "\n";
 447      $self->[XML::XPath::Node::node_parent] = $parent;
 448  }
 449  
 450  sub del_parent_link {
 451      my $self = shift;
 452      $self->[XML::XPath::Node::node_parent] = undef;
 453  }
 454  
 455  sub dispose {
 456      my $self = shift;
 457      foreach my $kid ($self->getChildNodes) {
 458          $kid->dispose;
 459      }
 460      foreach my $kid ($self->getAttributeNodes) {
 461          $kid->dispose;
 462      }
 463      foreach my $kid ($self->getNamespaceNodes) {
 464          $kid->dispose;
 465      }
 466      $self->[XML::XPath::Node::node_parent] = undef;
 467  }
 468  
 469  sub to_number {
 470      my $num = shift->string_value;
 471      return XML::XPath::Number->new($num);
 472  }
 473  
 474  sub find {
 475      my $node = shift;
 476      my ($path) = @_;
 477      my $xp = XML::XPath->new(); # new is v. lightweight
 478      return $xp->find($path, $node);
 479  }
 480  
 481  sub findvalue {
 482      my $node = shift;
 483      my ($path) = @_;
 484      my $xp = XML::XPath->new();
 485      return $xp->findvalue($path, $node);
 486  }
 487  
 488  sub findnodes {
 489      my $node = shift;
 490      my ($path) = @_;
 491      my $xp = XML::XPath->new();
 492      return $xp->findnodes($path, $node);
 493  }
 494  
 495  sub matches {
 496      my $node = shift;
 497      my ($path, $context) = @_;
 498      my $xp = XML::XPath->new();
 499      return $xp->matches($node, $path, $context);
 500  }
 501  
 502  sub to_sax {
 503      my $self = shift;
 504      unshift @_, 'Handler' if @_ == 1;
 505      my %handlers = @_;
 506      
 507      my $doch = $handlers{DocumentHandler} || $handlers{Handler};
 508      my $dtdh = $handlers{DTDHandler} || $handlers{Handler};
 509      my $enth = $handlers{EntityResolver} || $handlers{Handler};
 510  
 511      $self->_to_sax ($doch, $dtdh, $enth);
 512  }
 513  
 514  sub DESTROY {}
 515  
 516  use Carp;
 517  
 518  sub _to_sax {
 519      carp "_to_sax not implemented in ", ref($_[0]);
 520  }
 521  
 522  1;
 523  __END__
 524  
 525  =head1 NAME
 526  
 527  XML::XPath::Node - internal representation of a node
 528  
 529  =head1 API
 530  
 531  The Node API aims to emulate DOM to some extent, however the API
 532  isn't quite compatible with DOM. This is to ease transition from
 533  XML::DOM programming to XML::XPath. Compatibility with DOM may
 534  arise once XML::DOM gets namespace support.
 535  
 536  =head2 new
 537  
 538  Creates a new node. See the sub-classes for parameters to pass to new().
 539  
 540  =head2 getNodeType
 541  
 542  Returns one of ELEMENT_NODE, TEXT_NODE, COMMENT_NODE, ATTRIBUTE_NODE,
 543  PROCESSING_INSTRUCTION_NODE or NAMESPACE_NODE. UNKNOWN_NODE is returned
 544  if the sub-class doesn't implement getNodeType - but that means
 545  something is broken! The constants are exported by default from
 546  XML::XPath::Node. The constants have the same numeric value as the
 547  XML::DOM versions.
 548  
 549  =head2 getParentNode
 550  
 551  Returns the parent of this node, or undef if this is the root node. Note
 552  that the root node is the root node in terms of XPath - not the root
 553  element node.
 554  
 555  =head2 to_sax ( $handler | %handlers )
 556  
 557  Generates sax calls to the handler or handlers. See the PerlSAX docs for
 558  details (not yet implemented correctly).
 559  
 560  =head1 MORE INFO
 561  
 562  See the sub-classes for the meaning of the rest of the API:
 563  
 564  =over 4
 565  
 566  =item *
 567  
 568  L<XML::XPath::Node::Element>
 569  
 570  =item *
 571  
 572  L<XML::XPath::Node::Attribute>
 573  
 574  =item *
 575  
 576  L<XML::XPath::Node::Namespace>
 577  
 578  =item *
 579  
 580  L<XML::XPath::Node::Text>
 581  
 582  =item *
 583  
 584  L<XML::XPath::Node::Comment>
 585  
 586  =item *
 587  
 588  L<XML::XPath::Node::PI>
 589  
 590  =back
 591  
 592  =cut