src/DOM.pm

   1 package DOM;
   2
   3 # $Id$
   4 # Copyright (C) 2002-2005 Freescale Semiconductor, Inc.
   5 # Distributed under terms of the GNU General Public License (GPL).
   6
   7 # This package contains routines for Document Object Model (DOM) objects.
   8 # A DOM object is the prest equivalent of a doctree object.
   9
  10 # Data structures:
  11 #   _`DOM`: Recursive hash reference with following
  12 #     keys:
  13 #       ``tag``:      The name of the tag of the DOM object
  14 #       ``attr``:     Reference to hash of attribute/value pairs
  15 #       ``content``:  Reference to array of DOM objects
  16 #       ``text``:     Contains the literal text for #PCDATA
  17 #       ``internal``: Reference to hash of internal attribute/value pairs
  18 #       ``source``:   Optionally contains the source
  19 #       ``lineno``:   Optionally contains the line number
  20 #       ``lit``:      Optionally contains the literal text
  21 #       ``val``:      The value returned by the DOM's handler (added
  22 #                     during traversal of the writer's handlers)
  23
  24 # Global variables:
  25 #   ``%DOM::PARENT``: hash whose keys are DOM references and whose values are
  26 #                     a reference to the DOM object of the parent.
  27 #                     Should only be accessed indirectly through the
  28 #                     ``DOM::parent`` method.
  29
  30 use strict;
  31 use vars qw(%PARENT);
  32
  33 # CLASS METHOD.
  34 # Creates a new DOM object.
  35 # Arguments: (optional) tag, (optional) list of attribute/value pairs
  36 # Returns: DOM object
  37 sub new {
  38     my ($class, $tag, %attr) = @_;
  39
  40     my $dom = bless { };
  41     $dom->{tag} = $tag if defined $tag;
  42     $dom->{attr} = {%attr} if %attr;
  43     $dom->{content} = [];
  44     return $dom;
  45 }
  46
  47 # CLASS METHOD.
  48 # Creates a new DOM object that is a "#PCDATA" type.
  49 # Arguments: text
  50 # Returns: DOM object
  51 sub newPCDATA {
  52     my ($class, $text) = @_;
  53
  54     return bless {tag=>'#PCDATA', text=>$text, content=>[] };
  55 }
  56
  57 # INSTANCE METHOD.
  58 # Appends to the contents of a DOM object.
  59 # Arguments: DOM objects to append
  60 # Returns: The new number of contents
  61 sub append {
  62     my ($dom, @doms) = @_;
  63
  64     @PARENT{@doms} = ($dom) x @doms;
  65 #    grep do {$_->{parent} = $dom}, @doms;
  66     push @{$dom->{content}}, @doms;
  67 }
  68
  69 # INSTANCE METHOD.
  70 # Returns the content objects the DOM object has
  71 # Arguments: None
  72 # Returns: Array of content DOM objects
  73 sub contents {
  74     my ($dom, @doms) = @_;
  75
  76     return @{$dom->{content}};
  77 }
  78
  79 # INSTANCE METHOD.
  80 # Returns the index of a child in the contents (-1 if it does not occur).
  81 # Arguments: child DOM object
  82 # Returns: index number
  83 sub index {
  84     my ($dom, $child) = @_;
  85     my $i;
  86     for ($i=0; $i<@{$dom->{content}}; $i++) {
  87         return $i if $dom->{content}[$i] == $child;
  88     }
  89     return -1;
  90 }
  91
  92 # INSTANCE METHOD.
  93 # Returns the last DOM in the contents of a DOM.
  94 # Arguments: None
  95 # Returns: last DOM object (or undefined)
  96 sub last {
  97     my ($dom) = @_;
  98
  99     my $last;
 100     if (@{$dom->{content}}) {
 101         $last = $dom->{content}[-1];
 102     }
 103     return $last;
 104 }
 105
 106 # INSTANCE METHOD.
 107 # Returns the next DOM in the logical structure of the tree.  If the
 108 # given DOM is the last in a section or list, this routine may have to
 109 # go up in the tree to find the next object.
 110 # Arguments: optional regular expression for tags to ignore
 111 # Returns: next DOM or undef
 112 sub next {
 113     my ($dom, $ignore) = @_;
 114
 115 #    my $parent = $dom->{parent};
 116     my $parent = $dom->parent();
 117     my $indx = $parent->index($dom) + 1;
 118     my $cur_parent = $parent;
 119     while (defined $cur_parent) {
 120         while ($indx < $cur_parent->num_contents()) {
 121             my $tag = $cur_parent->{content}[$indx]{tag};
 122             if (defined $ignore && $tag =~ /^(?:$ignore)$/) {
 123                 # It's a skippable tag
 124                 $indx++;
 125                 next;
 126             }
 127             return $cur_parent->{content}[$indx];
 128         }
 129         my $new_parent = $cur_parent->parent();
 130         return unless defined $new_parent;
 131         $indx = $new_parent->index($cur_parent) + 1;
 132         $cur_parent = $new_parent;
 133     }
 134     return;
 135 }
 136
 137 # INSTANCE METHOD.
 138 # Returns the number of content objects the DOM object has
 139 # Arguments: None
 140 # Returns: Number of elements
 141 sub num_contents {
 142     my ($dom, @doms) = @_;
 143
 144     return 0+@{$dom->{content}};
 145 }
 146
 147 # INSTANCE METHOD.
 148 # Returns the parent DOM of an instance.
 149 # Arguments: None
 150 # Returns: The DOM object's parent
 151 sub parent {
 152     my ($dom) = @_;
 153
 154     return $PARENT{$dom};
 155 }
 156
 157 # INSTANCE METHOD.
 158 # Puts the arguments at the beginning of the contents of a DOM object.
 159 # Arguments: DOM objects to prepend
 160 # Returns: The new number of objects
 161 sub prepend {
 162     my ($dom, @doms) = @_;
 163
 164     @PARENT{@doms} = ($dom) x @doms;
 165 #    grep do {$_->{parent} = $dom}, @doms;
 166     unshift (@{$dom->{content}}, @doms);
 167 }
 168
 169 # INSTANCE METHOD.
 170 # Goes through a DOM object recursively calling a subroutine on every
 171 # element.  It can do either preorder, postorder or bothorder traversal
 172 # (defaults to postorder).  Unlike Reshape, it does not modify the
 173 # children of the nodes it visits.
 174 # Arguments: callback routine, optional 'pre'/'post'/'both',
 175 #            optional additional arguments to be propagated
 176 # Returns: Stop recursion flag
 177 # Callback routine arguments: target DOM, 'pre'/'post',
 178 #                             optional additional arguments
 179 # Callback routine returns: non-zero in 'pre' mode to avoid further recursion.
 180 sub Recurse {
 181     my($dom, $sub, $when, @args) = @_;
 182
 183     $when = 'post' unless defined $when;
 184     my $stop;
 185     if ($when =~ /^(pre|both)$/) {
 186         $stop = eval { &{$sub}($dom, 'pre', @args) };
 187         die "Error: $sub: $@" if $@;
 188     }
 189     return if $stop;
 190
 191     my @contents = @{$dom->{content}};
 192     my $i;
 193     for ($i=0; $i<@contents; $i++) {
 194         my $content = $contents[$i];
 195         $content->Recurse($sub, $when, @args);
 196     }
 197
 198     if ($when ne 'pre') {
 199         eval { &{$sub}($dom, 'post', @args) };
 200         die "Error: $sub: $@" if $@;
 201     }
 202 }
 203
 204 # INSTANCE METHOD.
 205 # Replaces the contents of a DOM object with a new set of objects.
 206 # Arguments: DOM objects to replace
 207 # Returns: None
 208 sub replace {
 209     my ($dom, @doms) = @_;
 210
 211     @PARENT{@doms} = ($dom) x @doms;
 212 #    grep do {$_->{parent} = $dom}, @doms;
 213     @{$dom->{content}} = @doms;
 214     return;
 215 }
 216
 217 # INSTANCE METHOD.
 218 # Goes through a DOM object recursively calling a subroutine on every
 219 # element.  It can do either preorder, postorder or bothorder traversal
 220 # (defaults to postorder).
 221 # Arguments: callback routine, optional 'pre'/'post'/'both',
 222 #            optional additional arguments to be propagated
 223 # Returns: Reference to new set objects to replace the current object
 224 # Callback routine arguments: target DOM, 'pre'/'post',
 225 #                             optional additional arguments
 226 # Callback routine returns: whatever list of DOM objects are to be
 227 #                           substituted for the current node (this
 228 #                           list is returned on the 'post' call if
 229 #                           'both' is selected).
 230 sub Reshape {
 231     my($dom, $sub, $when, @args) = @_;
 232
 233     $when = 'post' unless defined $when;
 234     my @newdom;
 235     if ($when =~ /^(pre|both)$/) {
 236         @newdom = eval { &{$sub}($dom, 'pre', @args) };
 237         die "Error: $sub: $@" if $@;
 238     }
 239
 240     my @contents = @{$dom->{content}};
 241     my $i;
 242     my $replace = 0;
 243     for ($i=0; $i<@contents; $i++) {
 244         my $content = $contents[$i];
 245         my @new_contents = grep(defined $_,
 246                                 $content->Reshape($sub, $when, @args));
 247         $dom->splice($replace, 1, @new_contents);
 248         $replace += @new_contents;
 249     }
 250
 251     if ($when ne 'pre') {
 252         @newdom = eval { &{$sub}($dom, 'post', @args) };
 253         die "Error: $sub: $@" if $@;
 254     }
 255
 256     return @newdom;
 257 }
 258
 259 # INSTANCE METHOD.
 260 # Splices objects into the contents of a DOM object.
 261 # Arguments: start index, number to replace, list of DOM objects to splice
 262 # Returns: Array of removed objects
 263 sub splice {
 264     my ($dom, $index, $n, @doms) = @_;
 265
 266     @PARENT{@doms} = ($dom) x @doms;
 267 #    grep do {$_->{parent} = $dom}, @doms;
 268     return splice(@{$dom->{content}}, $index, $n, @doms);
 269 }
 270
 271
 272 1;