home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _5a85b816572845bbf411024e80b716b4 < prev    next >
Encoding:
Text File  |  2004-06-01  |  118.9 KB  |  3,949 lines
  1.  
  2. require 5;
  3. # Time-stamp: "2003-09-15 01:03:09 ADT"
  4. package HTML::Element;
  5.  
  6. =head1 NAME
  7.  
  8. HTML::Element - Class for objects that represent HTML elements
  9.  
  10. =head1 SYNOPSIS
  11.  
  12.   use HTML::Element;
  13.   $a = HTML::Element->new('a', href => 'http://www.perl.com/');
  14.   $a->push_content("The Perl Homepage");
  15.  
  16.   $tag = $a->tag;
  17.   print "$tag starts out as:",  $a->starttag, "\n";
  18.   print "$tag ends as:",  $a->endtag, "\n";
  19.   print "$tag\'s href attribute is: ", $a->attr('href'), "\n";
  20.  
  21.   $links_r = $a->extract_links();
  22.   print "Hey, I found ", scalar(@$links_r), " links.\n";
  23.  
  24.   print "And that, as HTML, is: ", $a->as_HTML, "\n";
  25.   $a = $a->delete;
  26.  
  27. =head1 DESCRIPTION
  28.  
  29. (This class is part of the L<HTML::Tree|HTML::Tree> dist.)
  30.  
  31. Objects of the HTML::Element class can be used to represent elements
  32. of HTML document trees.  These objects have attributes, notably attributes that
  33. designates each element's parent and content.  The content is an array
  34. of text segments and other HTML::Element objects.  A tree with HTML::Element
  35. objects as nodes can represent the syntax tree for a HTML document.
  36.  
  37. =head1 HOW WE REPRESENT TREES
  38.  
  39. It may occur to you to wonder what exactly a "tree" is, and how
  40. it's represented in memory.  Consider this HTML document:
  41.  
  42.   <html lang='en-US'>
  43.     <head>
  44.       <title>Stuff</title>
  45.       <meta name='author' content='Jojo'>
  46.     </head>
  47.     <body>
  48.      <h1>I like potatoes!</h1>
  49.     </body>
  50.   </html>
  51.  
  52. Building a syntax tree out of it makes a tree-structure in memory
  53. that could be diagrammed as:
  54.  
  55.                      html (lang='en-US')
  56.                       / \
  57.                     /     \
  58.                   /         \
  59.                 head        body
  60.                /\               \
  61.              /    \               \
  62.            /        \               \
  63.          title     meta              h1
  64.           |       (name='author',     |
  65.        "Stuff"    content='Jojo')    "I like potatoes"
  66.  
  67. This is the traditional way to diagram a tree, with the "root" at the
  68. top, and it's this kind of diagram that people have in mind when they
  69. say, for example, that "the meta element is under the head element
  70. instead of under the body element".  (The same is also said with
  71. "inside" instead of "under" -- the use of "inside" makes more sense
  72. when you're looking at the HTML source.)
  73.  
  74. Another way to represent the above tree is with indenting:
  75.  
  76.   html (attributes: lang='en-US')
  77.     head
  78.       title
  79.         "Stuff"
  80.       meta (attributes: name='author' content='Jojo')
  81.     body
  82.       h1
  83.         "I like potatoes"
  84.  
  85. Incidentally, diagramming with indenting works much better for very
  86. large trees, and is easier for a program to generate.  The $tree->dump
  87. method uses indentation just that way.
  88.  
  89. However you diagram the tree, it's stored the same in memory -- it's a
  90. network of objects, each of which has attributes like so:
  91.  
  92.   element #1:  _tag: 'html'
  93.                _parent: none
  94.                _content: [element #2, element #5]
  95.                lang: 'en-US'
  96.  
  97.   element #2:  _tag: 'head'
  98.                _parent: element #1
  99.                _content: [element #3, element #4]
  100.  
  101.   element #3:  _tag: 'title'
  102.                _parent: element #2
  103.                _content: [text segment "Stuff"]
  104.  
  105.   element #4   _tag: 'meta'
  106.                _parent: element #2
  107.                _content: none
  108.                name: author
  109.                content: Jojo
  110.  
  111.   element #5   _tag: 'body'
  112.                _parent: element #1
  113.                _content: [element #6]
  114.  
  115.   element #6   _tag: 'h1'
  116.                _parent: element #5
  117.                _content: [text segment "I like potatoes"]
  118.  
  119. The "treeness" of the tree-structure that these elements comprise is
  120. not an aspect of any particular object, but is emergent from the
  121. relatedness attributes (_parent and _content) of these element-objects
  122. and from how you use them to get from element to element.
  123.  
  124. While you could access the content of a tree by writing code that says
  125. "access the 'src' attribute of the root's I<first> child's I<seventh>
  126. child's I<third> child", you're more likely to have to scan the contents
  127. of a tree, looking for whatever nodes, or kinds of nodes, you want to
  128. do something with.  The most straightforward way to look over a tree
  129. is to "traverse" it; an HTML::Element method ($h->traverse) is
  130. provided for this purpose; and several other HTML::Element methods are
  131. based on it.
  132.  
  133. (For everything you ever wanted to know about trees, and then some,
  134. see Niklaus Wirth's I<Algorithms + Data Structures = Programs> or
  135. Donald Knuth's I<The Art of Computer Programming, Volume 1>.)
  136.  
  137. =cut
  138.  
  139.  
  140. use strict;
  141. use Carp ();
  142. use HTML::Entities ();
  143. use HTML::Tagset ();
  144. use integer; # vroom vroom!
  145.  
  146. use vars qw($VERSION $html_uc $Debug $ID_COUNTER %list_type_to_sub);
  147.  
  148. $VERSION = '3.16';
  149. $Debug = 0 unless defined $Debug;
  150. sub Version { $VERSION; }
  151.  
  152. my $nillio = [];
  153.  
  154. *HTML::Element::emptyElement = \%HTML::Tagset::emptyElement; # legacy
  155. *HTML::Element::optionalEndTag = \%HTML::Tagset::optionalEndTag; # legacy
  156. *HTML::Element::linkElements = \%HTML::Tagset::linkElements; # legacy
  157. *HTML::Element::boolean_attr = \%HTML::Tagset::boolean_attr; # legacy
  158. *HTML::Element::canTighten = \%HTML::Tagset::canTighten; # legacy
  159.  
  160. # Constants for signalling back to the traverser:
  161. my $travsignal_package = __PACKAGE__ . '::_travsignal';
  162. my(
  163.   $ABORT, $PRUNE, $PRUNE_SOFTLY, $OK, $PRUNE_UP
  164. ) =
  165.   map
  166.    {my $x = $_ ; bless \$x, $travsignal_package;}
  167.    qw(
  168.      ABORT  PRUNE   PRUNE_SOFTLY   OK   PRUNE_UP
  169.    )
  170. ;
  171. sub ABORT           () {$ABORT}
  172. sub PRUNE           () {$PRUNE}
  173. sub PRUNE_SOFTLY    () {$PRUNE_SOFTLY}
  174. sub OK              () {$OK}
  175. sub PRUNE_UP        () {$PRUNE_UP}
  176.  
  177. $html_uc = 0;
  178. # set to 1 if you want tag and attribute names from starttag and endtag
  179. #  to be uc'd
  180.  
  181. # Elements that does not have corresponding end tags (i.e. are empty)
  182.  
  183. #==========================================================================
  184.  
  185.  
  186. =head1 BASIC METHODS
  187.  
  188. =over 4
  189.  
  190. =item $h = HTML::Element->new('tag', 'attrname' => 'value', ... )
  191.  
  192. This constructor method returns a new HTML::Element object.  The tag
  193. name is a required argument; it will be forced to lowercase.
  194. Optionally, you can specify other initial attributes at object
  195. creation time.
  196.  
  197. =cut
  198.  
  199. #
  200. # An HTML::Element is represented by blessed hash reference, much like
  201. # Tree::DAG_Node objects.  Key-names not starting with '_' are reserved
  202. # for the SGML attributes of the element.
  203. # The following special keys are used:
  204. #
  205. #    '_tag':    The tag name (i.e., the generic identifier)
  206. #    '_parent': A reference to the HTML::Element above (when forming a tree)
  207. #    '_pos':    The current position (a reference to a HTML::Element) is
  208. #               where inserts will be placed (look at the insert_element
  209. #               method)  If not set, the implicit value is the object itself.
  210. #    '_content': A ref to an array of nodes under this.
  211. #                It might not be set.
  212. #
  213. # Example: <img src="gisle.jpg" alt="Gisle's photo"> is represented like this:
  214. #
  215. #  bless {
  216. #     _tag => 'img',
  217. #     src  => 'gisle.jpg',
  218. #     alt  => "Gisle's photo",
  219. #  }, 'HTML::Element';
  220. #
  221.  
  222. sub new
  223. {
  224.     my $class = shift;
  225.     $class = ref($class) || $class;
  226.  
  227.     my $tag   = shift;
  228.     Carp::croak("No tagname") unless defined $tag and length $tag;
  229.     Carp::croak "\"$tag\" isn't a good tag name!"
  230.      if $tag =~ m/[<>\/\x00-\x20]/; # minimal sanity, certainly!
  231.     my $self  = bless { _tag => scalar($class->_fold_case($tag)) }, $class;
  232.     my($attr, $val);
  233.     while (($attr, $val) = splice(@_, 0, 2)) {
  234.         $val = $attr unless defined $val;
  235.         $self->{$class->_fold_case($attr)} = $val;
  236.     }
  237.     if ($tag eq 'html') {
  238.         $self->{'_pos'} = undef;
  239.     }
  240.     $self;
  241. }
  242.  
  243.  
  244. =item $h->attr('attr') or $h->attr('attr', 'value')
  245.  
  246. Returns (optionally sets) the value of the given attribute of $h.  The
  247. attribute name (but not the value, if provided) is forced to
  248. lowercase.  If trying to read the value of an attribute not present
  249. for this element, the return value is undef.
  250. If setting a new value, the old value of that attribute is
  251. returned.
  252.  
  253. If methods are provided for accessing an attribute (like $h->tag for
  254. "_tag", $h->content_list, etc. below), use those instead of calling
  255. attr $h->attr, whether for reading or setting.
  256.  
  257. Note that setting an attribute to undef (as opposed to "", the empty
  258. string) actually deletes the attribute.
  259.  
  260. =cut
  261.  
  262. sub attr
  263. {
  264.     my $self = shift;
  265.     my $attr = scalar($self->_fold_case(shift));
  266.     if (@_) {  # set
  267.         if(defined $_[0]) {
  268.             my $old = $self->{$attr};
  269.             $self->{$attr} = $_[0];
  270.             return $old;
  271.         } else {  # delete, actually
  272.             return delete $self->{$attr};
  273.         }
  274.     } else {   # get
  275.         return $self->{$attr};
  276.     }
  277. }
  278.  
  279.  
  280. =item $h->tag() or $h->tag('tagname')
  281.  
  282. Returns (optionally sets) the tag name (also known as the generic
  283. identifier) for the element $h.  In setting, the tag name is always
  284. converted to lower case.
  285.  
  286. There are four kinds of "pseudo-elements" that show up as
  287. HTML::Element objects:
  288.  
  289. =over
  290.  
  291. =item Comment pseudo-elements
  292.  
  293. These are element objects with a C<$h-E<gt>tag> value of "~comment",
  294. and the content of the comment is stored in the "text" attribute
  295. (C<$h-E<gt>attr("text")>).  For example, parsing this code with
  296. HTML::TreeBuilder...
  297.  
  298.   <!-- I like Pie.
  299.      Pie is good
  300.   -->
  301.  
  302. produces an HTML::Element object with these attributes:
  303.  
  304.   "_tag",
  305.   "~comment",
  306.   "text",
  307.   " I like Pie.\n     Pie is good\n  "
  308.  
  309. =item Declaration pseudo-elements
  310.  
  311. Declarations (rarely encountered) are represented as HTML::Element
  312. objects with a tag name of "~declaration", and content in the "text"
  313. attribute.  For example, this:
  314.  
  315.   <!DOCTYPE foo>
  316.  
  317. produces an element whose attributes include:
  318.  
  319.   "_tag", "~declaration", "text", "DOCTYPE foo"
  320.  
  321. =item Processing instruction pseudo-elements
  322.  
  323. PIs (rarely encountered) are represented as HTML::Element objects with
  324. a tag name of "~pi", and content in the "text" attribute.  For
  325. example, this:
  326.  
  327.   <?stuff foo?>
  328.  
  329. produces an element whose attributes include:
  330.  
  331.   "_tag", "~pi", "text", "stuff foo?"
  332.  
  333. (assuming a recent version of HTML::Parser)
  334.  
  335. =item ~literal pseudo-elements
  336.  
  337. These objects are not currently produced by HTML::TreeBuilder, but can
  338. be used to represent a "super-literal" -- i.e., a literal you want to
  339. be immune from escaping.  (Yes, I just made that term up.)
  340.  
  341. That is, this is useful if you want to insert code into a tree that
  342. you plan to dump out with C<as_HTML>, where you want, for some reason,
  343. to suppress C<as_HTML>'s normal behavior of amp-quoting text segments.
  344.  
  345. For expample, this:
  346.  
  347.   my $literal = HTML::Element->new('~literal',
  348.     'text' => 'x < 4 & y > 7'
  349.   );
  350.   my $span = HTML::Element->new('span');
  351.   $span->push_content($literal);
  352.   print $span->as_HTML;
  353.  
  354. prints this:
  355.  
  356.   <span>x < 4 & y > 7</span>
  357.  
  358. Whereas this:
  359.  
  360.   my $span = HTML::Element->new('span');
  361.   $span->push_content('x < 4 & y > 7');
  362.     # normal text segment
  363.   print $span->as_HTML;
  364.  
  365. prints this:
  366.  
  367.   <span>x < 4 & y > 7</span>
  368.  
  369. Unless you're inserting lots of pre-cooked code into existing trees,
  370. and dumping them out again, it's not likely that you'll find
  371. C<~literal> pseudo-elements useful.
  372.  
  373. =back
  374.  
  375. =cut
  376.  
  377. sub tag
  378. {
  379.     my $self = shift;
  380.     if (@_) { # set
  381.     #print "SET\n";
  382.         $self->{'_tag'} = $self->_fold_case($_[0]);
  383.     } else { # get
  384.     #print "GET\n";
  385.         $self->{'_tag'};
  386.     }
  387. }
  388.  
  389.  
  390. =item $h->parent() or $h->parent($new_parent)
  391.  
  392. Returns (optionally sets) the parent (aka "container") for this element.
  393. The parent should either be undef, or should be another element.
  394.  
  395. You B<should not> use this to directly set the parent of an element.
  396. Instead use any of the other methods under "Structure-Modifying
  397. Methods", below.
  398.  
  399. Note that not($h->parent) is a simple test for whether $h is the
  400. root of its subtree.
  401.  
  402. =cut
  403.  
  404. sub parent
  405. {
  406.     my $self = shift;
  407.     if (@_) { # set
  408.         Carp::croak "an element can't be made its own parent"
  409.          if defined $_[0] and ref $_[0] and $self eq $_[0]; # sanity
  410.         $self->{'_parent'} = $_[0];
  411.     } else {
  412.         $self->{'_parent'}; # get
  413.     }
  414. }
  415.  
  416.  
  417. =item $h->content_list()
  418.  
  419. Returns a list of the child nodes of this element -- i.e., what
  420. nodes (elements or text segments) are inside/under this element. (Note
  421. that this may be an empty list.)
  422.  
  423. In a scalar context, this returns the count of the items,
  424. as you may expect.
  425.  
  426. =cut
  427.  
  428. sub content_list
  429. {
  430.     return
  431.       wantarray ?        @{shift->{'_content'} || return()}
  432.                 : scalar @{shift->{'_content'} || return 0};
  433. }
  434.  
  435.  
  436.  
  437. =item $h->content()
  438.  
  439. This somewhat deprecated method returns the content of this element;
  440. but unlike content_list, this returns either undef (which you should
  441. understand to mean no content), or a I<reference to the array> of
  442. content items, each of which is either a text segment (a string, i.e.,
  443. a defined non-reference scalar value), or an HTML::Element object.
  444. Note that even if an arrayref is returned, it may be a reference to an
  445. empty array.
  446.  
  447. While older code should feel free to continue to use $h->content,
  448. new code should use $h->content_list in almost all conceivable
  449. cases.  It is my experience that in most cases this leads to simpler
  450. code anyway, since it means one can say:
  451.  
  452.   @children = $h->content_list;
  453.  
  454. instead of the inelegant:
  455.  
  456.   @children = @{$h->content || []};
  457.  
  458. If you do use $h->content (or $h->content_array_ref), you should not
  459. use the reference returned by it (assuming it returned a reference,
  460. and not undef) to directly set or change the content of an element or
  461. text segment!  Instead use C<content_refs_list> or any of the other
  462. methods under "Structure-Modifying Methods", below.
  463.  
  464. =cut
  465.  
  466. # a read-only method!  can't say $h->content( [] )!
  467. sub content
  468. {
  469.     shift->{'_content'};
  470. }
  471.  
  472.  
  473. =item $h->content_array_ref()
  474.  
  475. This is like C<content> (with all its caveats and deprecations) except
  476. that it is guaranteed to return an array reference.  That is, if the
  477. given node has no C<_content> attribute, the C<content> method would
  478. return that undef, but C<content_array_ref> would set the given node's
  479. C<_content> value to C<[]> (a reference to a new, empty array), and
  480. return that.
  481.  
  482. =cut
  483.  
  484. sub content_array_ref {
  485.   shift->{'_content'} ||= [];
  486. }
  487.  
  488.  
  489. =item $h->content_refs_list
  490.  
  491. This returns a list of scalar references to each element of $h's
  492. content list.  This is useful in case you want to in-place edit any
  493. large text segments without having to get a copy of the current value
  494. of that segment value, modify that copy, then use the
  495. C<splice_content> to replace the old with the new.  Instead, here you
  496. can in-place edit:
  497.  
  498.   foreach my $item_r ($h->content_refs_list) {
  499.     next if ref $$item_r;
  500.     $$item_r =~ s/honour/honor/g;
  501.   }
  502.  
  503. You I<could> currently achieve the same affect with:
  504.  
  505.   foreach my $item (@{ $h->content_array_ref }) {
  506.    # deprecated!
  507.     next if ref $item;
  508.     $item =~ s/honour/honor/g;
  509.   }
  510.  
  511. ...except that using the return value of $h->content or
  512. $h->content_array_ref to do that is deprecated, and just might stop
  513. working in the future.
  514.  
  515. =cut
  516.  
  517. sub content_refs_list {
  518.   \( @{ shift->{'_content'} || return() } );
  519. }
  520.  
  521.  
  522. =item $h->implicit() or $h->implicit($bool)
  523.  
  524. Returns (optionally sets) the "_implicit" attribute.  This attribute is
  525. a flag that's used for indicating that the element was not originally
  526. present in the source, but was added to the parse tree (by
  527. HTML::TreeBuilder, for example) in order to conform to the rules of
  528. HTML structure.
  529.  
  530. =cut
  531.  
  532. sub implicit
  533. {
  534.     shift->attr('_implicit', @_);
  535. }
  536.  
  537.  
  538.  
  539. =item $h->pos() or $h->pos($element)
  540.  
  541. Returns (and optionally sets) the "_pos" (for "current I<pos>ition")
  542. pointer of $h.
  543. This attribute is a pointer used during some parsing operations,
  544. whose value is whatever HTML::Element element at or under $h is
  545. currently "open", where $h->insert_element(NEW) will actually insert a
  546. new element.
  547.  
  548. (This has nothing to do with the Perl function called "pos", for
  549. controlling where regular expression matching starts.)
  550.  
  551. If you set $h->pos($element), be sure that $element is either $h, or
  552. an element under $h.
  553.  
  554. If you've been modifying the tree under $h and are
  555. no longer sure $h->pos is valid, you can enforce validity with:
  556.  
  557.     $h->pos(undef) unless $h->pos->is_inside($h);
  558.  
  559. =cut
  560.  
  561. sub pos
  562. {
  563.     my $self = shift;
  564.     my $pos = $self->{'_pos'};
  565.     if (@_) {  # set
  566.         if(defined $_[0] and $_[0] ne $self) {
  567.           $self->{'_pos'} = $_[0]; # means that element
  568.         } else {
  569.           $self->{'_pos'} = undef; # means $self
  570.         }
  571.     }
  572.     return $pos if defined($pos);
  573.     $self;
  574. }
  575.  
  576.  
  577. =item $h->all_attr()
  578.  
  579. Returns all this element's attributes and values, as key-value pairs.
  580. This will include any "internal" attributes (i.e., ones not present
  581. in the original element, and which will not be represented if/when you
  582. call $h->as_HTML).  Internal attributes are distinguished by the fact
  583. that the first character of their key (not value! key!) is an
  584. underscore ("_").
  585.  
  586. Example output of C<$h-E<gt>all_attr()> :
  587. C<'_parent', >I<[object_value]>C< , '_tag', 'em', 'lang', 'en-US',
  588. '_content', >I<[array-ref value]>.
  589.  
  590. =item $h->all_attr_names()
  591.  
  592. Like all_attr, but only returns the names of the attributes.
  593.  
  594. Example output of C<$h-E<gt>all_attr()> :
  595. C<'_parent', '_tag', 'lang', '_content', >.
  596.  
  597. =cut
  598.  
  599. sub all_attr {
  600.   return %{$_[0]};
  601.   # Yes, trivial.  But no other way for the user to do the same
  602.   #  without breaking encapsulation.
  603.   # And if our object representation changes, this method's behavior
  604.   #  should stay the same.
  605. }
  606.  
  607. sub all_attr_names {
  608.   return keys %{$_[0]};
  609. }
  610.  
  611.  
  612. =item $h->all_external_attr()
  613.  
  614. Like C<all_attr>, except that internal attributes are not present.
  615.  
  616. =item $h->all_external_attr_names()
  617.  
  618. Like C<all_external_attr_names>, except that internal attributes' names
  619. are not present.
  620.  
  621. =cut
  622.  
  623. sub all_external_attr {
  624.   my $self = $_[0];
  625.   return
  626.     map(
  627.         (length($_) && substr($_,0,1) eq '_') ? () : ($_, $self->{$_}),
  628.         keys %$self
  629.        );
  630. }
  631.  
  632. sub all_external_attr_names {
  633.   return
  634.     grep
  635.       !(length($_) && substr($_,0,1) eq '_'),
  636.       keys %{$_[0]}
  637.   ;
  638. }
  639.  
  640.  
  641.  
  642. =item $h->id() or $h->id($string)
  643.  
  644. Returns (optionally sets to C<$string>) the "id" attribute.
  645. C<$h-E<gt>id(undef)> deletes the "id" attribute.
  646.  
  647. =cut
  648.  
  649. sub id {
  650.   if(@_ == 1) {
  651.     return $_[0]{'id'};
  652.   } elsif(@_ == 2) {
  653.     if(defined $_[1]) {
  654.       return $_[0]{'id'} = $_[1];
  655.     } else {
  656.       return delete $_[0]{'id'};
  657.     }
  658.   } else {
  659.     Carp::croak '$node->id can\'t take ' . scalar(@_) . ' parameters!';
  660.   }
  661. }
  662.  
  663.  
  664. =item $h->idf() or $h->idf($string)
  665.  
  666. Just like the C<id> method, except that if you call C<$h-E<gt>idf()> and
  667. no "id" attribute is defined for this element, then it's set to a
  668. likely-to-be-unique value, and returned.  (The "f" is for "force".)
  669.  
  670. =cut
  671.  
  672. sub _gensym {
  673.   unless(defined $ID_COUNTER) {
  674.     # start it out...
  675.     $ID_COUNTER = sprintf('%04x', rand(0x1000));
  676.     $ID_COUNTER =~ tr<0-9a-f><J-NP-Z>; # yes, skip letter "oh"
  677.     $ID_COUNTER .= '00000';
  678.   }
  679.   ++$ID_COUNTER;
  680. }
  681.  
  682. sub idf {
  683.   if(@_ == 1) {
  684.     my $x;
  685.     if(defined($x = $_[0]{'id'}) and length $x) {
  686.       return $x;
  687.     } else {
  688.       return $_[0]{'id'} = _gensym();
  689.     }
  690.   } elsif(@_ == 2) {
  691.     if(defined $_[1]) {
  692.       return $_[0]{'id'} = $_[1];
  693.     } else {
  694.       return delete $_[0]{'id'};
  695.     }
  696.   } else {
  697.     Carp::croak '$node->idf can\'t take ' . scalar(@_) . ' parameters!';
  698.   }
  699. }
  700.  
  701. #==========================================================================
  702.  
  703. =back
  704.  
  705. =head1 STRUCTURE-MODIFYING METHODS
  706.  
  707. These methods are provided for modifying the content of trees
  708. by adding or changing nodes as parents or children of other nodes.
  709.  
  710. =over 4
  711.  
  712. =item $h->push_content($element_or_text, ...)
  713.  
  714. Adds the specified items to the I<end> of the content list of the
  715. element $h.  The items of content to be added should each be either a
  716. text segment (a string), an HTML::Element object, or an arrayref.
  717. Arrayrefs are fed thru C<$h-E<gt>new_from_lol(that_arrayref)> to
  718. convert them into elements, before being added to the content
  719. list of $h.  This means you can say things concise things like:
  720.  
  721.   $body->push_content(
  722.     ['br'],
  723.     ['ul',
  724.       map ['li', $_]
  725.       qw(Peaches Apples Pears Mangos)
  726.     ]
  727.   );
  728.  
  729. See C<new_from_lol> method's documentation, far below, for more
  730. explanation.
  731.  
  732. The push_content method will try to consolidate adjacent text segments
  733. while adding to the content list.  That's to say, if $h's content_list is
  734.  
  735.   ('foo bar ', $some_node, 'baz!')
  736.  
  737. and you call
  738.  
  739.    $h->push_content('quack?');
  740.  
  741. then the resulting content list will be this:
  742.  
  743.   ('foo bar ', $some_node, 'baz!quack?')
  744.  
  745. and not this:
  746.  
  747.   ('foo bar ', $some_node, 'baz!', 'quack?')
  748.  
  749. If that latter is what you want, you'll have to override the
  750. feature of consolidating text by using splice_content,
  751. as in:
  752.  
  753.   $h->splice_content(scalar($h->content_list),0,'quack?');
  754.  
  755. Similarly, if you wanted to add 'Skronk' to the beginning of
  756. the content list, calling this:
  757.  
  758.    $h->unshift_content('Skronk');
  759.  
  760. then the resulting content list will be this:
  761.  
  762.   ('Skronkfoo bar ', $some_node, 'baz!')
  763.  
  764. and not this:
  765.  
  766.   ('Skronk', 'foo bar ', $some_node, 'baz!')
  767.  
  768. What you'd to do get the latter is:
  769.  
  770.   $h->splice_content(0,0,'Skronk');
  771.  
  772. =cut
  773.  
  774. sub push_content
  775. {
  776.     my $self = shift;
  777.     return $self unless @_;
  778.  
  779.     my $content = ($self->{'_content'} ||= []);
  780.     for (@_) {
  781.         if (ref($_) eq 'ARRAY') {
  782.             # magically call new_from_lol
  783.             push @$content, $self->new_from_lol($_);
  784.         $content->[-1]->{'_parent'} = $self;
  785.         } elsif(ref($_)) {  # insert an element
  786.             $_->detach if $_->{'_parent'};
  787.             $_->{'_parent'} = $self;
  788.             push(@$content, $_);
  789.         } else {  # insert text segment
  790.             if (@$content && !ref $content->[-1]) {
  791.                 # last content element is also text segment -- append
  792.                 $content->[-1] .= $_;
  793.             } else {
  794.                 push(@$content, $_);
  795.             }
  796.         }
  797.     }
  798.     $self;
  799. }
  800.  
  801.  
  802. =item $h->unshift_content($element_or_text, ...)
  803.  
  804. Just like C<push_content>, but adds to the I<beginning> of the $h
  805. element's content list.
  806.  
  807. The items of content to be added should each be
  808. either a text segment (a string), an HTML::Element object, or
  809. an arrayref (which is fed thru C<new_from_lol>).
  810.  
  811. The unshift_content method will try to consolidate adjacent text segments
  812. while adding to the content list.  See above for a discussion of this.
  813.  
  814. =cut
  815.  
  816. sub unshift_content
  817. {
  818.     my $self = shift;
  819.     return $self unless @_;
  820.  
  821.     my $content = ($self->{'_content'} ||= []);
  822.     for (reverse @_) { # so they get added in the order specified
  823.         if (ref($_) eq 'ARRAY') {
  824.             # magically call new_from_lol
  825.             unshift @$content, $self->new_from_lol($_);
  826.         $content->[0]->{'_parent'} = $self;
  827.         } elsif (ref $_) {  # insert an element
  828.             $_->detach if $_->{'_parent'};
  829.             $_->{'_parent'} = $self;
  830.             unshift(@$content, $_);
  831.         } else {  # insert text segment
  832.             if (@$content && !ref $content->[0]) {
  833.                 # last content element is also text segment -- prepend
  834.                 $content->[0]  = $_ . $content->[0];
  835.             } else {
  836.                 unshift(@$content, $_);
  837.             }
  838.         }
  839.     }
  840.     $self;
  841. }
  842.  
  843. # Cf.  splice ARRAY,OFFSET,LENGTH,LIST
  844.  
  845. =item $h->splice_content($offset, $length, $element_or_text, ...)
  846.  
  847. Detaches the elements from $h's list of content-nodes, starting at
  848. $offset and continuing for $length items, replacing them with the
  849. elements of the following list, if any.  Returns the elements (if any)
  850. removed from the content-list.  If $offset is negative, then it starts
  851. that far from the end of the array, just like Perl's normal C<splice>
  852. function.  If $length and the following list is omitted, removes
  853. everything from $offset onward.
  854.  
  855. The items of content to be added (if any) should each be either a text
  856. segment (a string), an arrayref (which is fed thru C<new_from_lol>),
  857. or an HTML::Element object that's not already
  858. a child of $h.
  859.  
  860. =cut
  861.  
  862. sub splice_content {
  863.     my($self, $offset, $length, @to_add) = @_;
  864.     Carp::croak
  865.       "splice_content requires at least one argument"
  866.       if @_ < 2;  # at least $h->splice_content($offset);
  867.     return $self unless @_;
  868.  
  869.     my $content = ($self->{'_content'} ||= []);
  870.     # prep the list
  871.  
  872.     my @out;
  873.     if(@_ > 2) {  # self, offset, length, ...
  874.       foreach my $n (@to_add) {
  875.         if(ref($n) eq 'ARRAY') {
  876.           $n = $self->new_from_lol($n);
  877.           $n->{'_parent'} = $self;
  878.         } elsif(ref($n)) {
  879.           $n->detach;
  880.           $n->{'_parent'} = $self;
  881.         }
  882.       }
  883.       @out = splice @$content, $offset, $length, @to_add;
  884.     } else {  #  self, offset
  885.       @out = splice @$content, $offset;
  886.     }
  887.     foreach my $n (@out) {
  888.       $n->{'_parent'} = undef if ref $n;
  889.     }
  890.     return @out;
  891. }
  892.  
  893.  
  894. =item $h->detach()
  895.  
  896. This unlinks $h from its parent, by setting its 'parent' attribute to
  897. undef, and by removing it from the content list of its parent (if it
  898. had one).  The return value is the parent that was detached from (or
  899. undef, if $h had no parent to start with).  Note that neither $h nor
  900. its parent are explicitly destroyed.
  901.  
  902. =cut
  903.  
  904. sub detach {
  905.   my $self = $_[0];
  906.   return undef unless(my $parent = $self->{'_parent'});
  907.   $self->{'_parent'} = undef;
  908.   my $cohort = $parent->{'_content'} || return $parent;
  909.   @$cohort = grep { not( ref($_) and $_ eq $self) } @$cohort;
  910.     # filter $self out, if parent has any evident content
  911.   
  912.   return $parent;
  913. }
  914.  
  915.  
  916. =item $h->detach_content()
  917.  
  918. This unlinks $h all of $h's children from $h, and returns them.
  919. Note that these are not explicitly destroyed; for that, you
  920. can just use $h->delete_content.
  921.  
  922. =cut
  923.  
  924. sub detach_content {
  925.   my $c = $_[0]->{'_content'} || return(); # in case of no content
  926.   for (@$c) { $_->{'_parent'} = undef if ref $_; }
  927.   return splice @$c;
  928. }
  929.  
  930.  
  931. =item $h->replace_with( $element_or_text, ... )
  932.  
  933. This replaces $h in its parent's content list with the nodes specified.
  934. The element $h (which by then may have no parent) is
  935. returned.  This causes a fatal error if $h has no parent.
  936. The list of nodes to insert may contain $h, but at most once.
  937. Aside from that possible exception, the nodes to insert should not
  938. already be children of $h's parent.
  939.  
  940. Also, note that this method does not destroy $h -- use
  941. $h->replace_with(...)->delete if you need that.
  942.  
  943. =cut
  944.  
  945. sub replace_with {
  946.   my($self, @replacers) = @_;
  947.   Carp::croak "the target node has no parent"
  948.     unless my($parent) = $self->{'_parent'};
  949.  
  950.   my $parent_content = $parent->{'_content'};
  951.   Carp::croak "the target node's parent has no content!?" 
  952.    unless $parent_content and @$parent_content;
  953.   
  954.   my $replacers_contains_self;
  955.   for(@replacers) {
  956.     if(!ref $_) {
  957.       # noop
  958.     } elsif($_ eq $self) {
  959.       # noop, but check that it's there just once.
  960.       Carp::croak 
  961.         "Replacement list contains several copies of target!"
  962.        if $replacers_contains_self++;
  963.     } elsif($_ eq $parent) {
  964.       Carp::croak "Can't replace an item with its parent!";
  965.     } elsif(ref($_) eq 'ARRAY') {
  966.       $_ = $self->new_from_lol($_);
  967.     } else {
  968.       $_->detach;
  969.       $_->{'_parent'} = $parent;
  970.       # each of these are necessary
  971.     }
  972.   }
  973.   
  974.   #my $content_r = $self->{'_content'} || [];
  975.   @$parent_content 
  976.    = map { ( ref($_) and $_ eq $self) ? @replacers : $_ }
  977.          @$parent_content
  978.   ;
  979.   
  980.   $self->{'_parent'} = undef unless $replacers_contains_self;
  981.    # if replacers does contain self, then the parent attribute is fine as-is
  982.   
  983.   return $self;
  984. }
  985.  
  986. =item $h->preinsert($element_or_text...)
  987.  
  988. Inserts the given nodes right BEFORE $h in $h's parent's content list.
  989. This causes a fatal error if $h has no parent.  None of the
  990. given nodes should be $h or other children of $h.  Returns $h.
  991.  
  992. =cut
  993.  
  994. sub preinsert {
  995.   my $self = shift;
  996.   return $self unless @_;
  997.   return $self->replace_with(@_, $self);
  998. }
  999.  
  1000. =item $h->postinsert($element_or_text...)
  1001.  
  1002. Inserts the given nodes right AFTER $h in $h's parent's content list.
  1003. This causes a fatal error if $h has no parent.  None of the
  1004. given nodes should be $h or other children of $h.  Returns $h.
  1005.  
  1006. =cut
  1007.  
  1008. sub postinsert {
  1009.   my $self = shift;
  1010.   return $self unless @_;
  1011.   return $self->replace_with($self, @_);
  1012. }
  1013.  
  1014.  
  1015. =item $h->replace_with_content()
  1016.  
  1017. This replaces $h in its parent's content list with its own content.
  1018. The element $h (which by then has no parent or content of its own) is
  1019. returned.  This causes a fatal error if $h has no parent.  Also, note
  1020. that this does not destroy $h -- use $h->replace_with_content->delete
  1021. if you need that.
  1022.  
  1023. =cut
  1024.  
  1025. sub replace_with_content {
  1026.   my $self = $_[0];
  1027.   Carp::croak "the target node has no parent"
  1028.     unless my($parent) = $self->{'_parent'};
  1029.  
  1030.   my $parent_content = $parent->{'_content'};
  1031.   Carp::croak "the target node's parent has no content!?" 
  1032.    unless $parent_content and @$parent_content;
  1033.  
  1034.   my $content_r = $self->{'_content'} || [];
  1035.   @$parent_content 
  1036.    = map { ( ref($_) and $_ eq $self) ? @$content_r : $_ }
  1037.          @$parent_content
  1038.   ;
  1039.  
  1040.   $self->{'_parent'} = undef; # detach $self from its parent
  1041.  
  1042.   # Update parentage link, removing from $self's content list
  1043.   for (splice @$content_r) {  $_->{'_parent'} = $parent if ref $_ }
  1044.  
  1045.   return $self;  # note: doesn't destroy it.
  1046. }
  1047.  
  1048.  
  1049.  
  1050. =item $h->delete_content()
  1051.  
  1052. Clears the content of $h, calling $i->delete for each content element.
  1053. Compare with $h->detach_content.
  1054.  
  1055. Returns $h.
  1056.  
  1057. =cut
  1058.  
  1059. sub delete_content
  1060. {
  1061.     for (splice @{ delete($_[0]->{'_content'})
  1062.               # Deleting it here (while holding its value, for the moment)
  1063.               #  will keep calls to detach() from trying to uselessly filter
  1064.               #  the list (as they won't be able to see it once it's been
  1065.               #  deleted)
  1066.             || return($_[0]) # in case of no content
  1067.           },
  1068.           0
  1069.            # the splice is so we can null the array too, just in case
  1070.            # something somewhere holds a ref to it
  1071.         )
  1072.     {
  1073.         $_->delete if ref $_;
  1074.     }
  1075.     $_[0];
  1076. }
  1077.  
  1078.  
  1079.  
  1080. =item $h->delete()
  1081.  
  1082. Detaches this element from its parent (if it has one) and explicitly
  1083. destroys the element and all its descendants.  The return value is
  1084. undef.
  1085.  
  1086. Perl uses garbage collection based on reference counting; when no
  1087. references to a data structure exist, it's implicitly destroyed --
  1088. i.e., when no value anywhere points to a given object anymore, Perl
  1089. knows it can free up the memory that the now-unused object occupies.
  1090.  
  1091. But this fails with HTML::Element trees, because a parent element
  1092. always holds references to its children, and its children elements
  1093. hold references to the parent, so no element ever looks like it's
  1094. I<not> in use.  So, to destroy those elements, you need to call
  1095. $h->delete on the parent.
  1096.  
  1097. =cut
  1098.  
  1099. #'
  1100.  
  1101. # two handy aliases
  1102. sub destroy { shift->delete(@_) }
  1103. sub destroy_content { shift->delete_content(@_) }
  1104.  
  1105. sub delete
  1106. {
  1107.     my $self = $_[0];
  1108.     $self->delete_content   # recurse down
  1109.      if $self->{'_content'} && @{$self->{'_content'}};
  1110.     
  1111.     $self->detach if $self->{'_parent'} and $self->{'_parent'}{'_content'};
  1112.      # not the typical case
  1113.  
  1114.     %$self = (); # null out the whole object on the way out
  1115.     return undef;
  1116. }
  1117.  
  1118.  
  1119.  
  1120. =item $h->clone()
  1121.  
  1122. Returns a copy of the element (whose children are clones (recursively)
  1123. of the original's children, if any).
  1124.  
  1125. The returned element is parentless.  Any '_pos' attributes present in the
  1126. source element/tree will be absent in the copy.  For that and other reasons,
  1127. the clone of an HTML::TreeBuilder object that's in mid-parse (i.e, the head
  1128. of a tree that HTML::TreeBuilder is elaborating) cannot (currently) be used
  1129. to continue the parse.
  1130.  
  1131. You are free to clone HTML::TreeBuilder trees, just as long as:
  1132. 1) they're done being parsed, or 2) you don't expect to resume parsing
  1133. into the clone.  (You can continue parsing into the original; it is
  1134. never affected.)
  1135.  
  1136. =cut
  1137.  
  1138. sub clone {
  1139.   #print "Cloning $_[0]\n";
  1140.   my $it = shift;
  1141.   Carp::croak "clone() can be called only as an object method" unless ref $it;
  1142.   Carp::croak "clone() takes no arguments" if @_;
  1143.  
  1144.   my $new = bless { %$it }, ref($it);     # COPY!!! HOOBOY!
  1145.   delete @$new{'_content', '_parent', '_pos', '_head', '_body'};
  1146.   
  1147.   # clone any contents
  1148.   if($it->{'_content'} and @{$it->{'_content'}}) {
  1149.     $new->{'_content'} = [  ref($it)->clone_list( @{$it->{'_content'}} )  ];
  1150.     for(@{$new->{'_content'}}) {
  1151.       $_->{'_parent'} = $new if ref $_;
  1152.     }
  1153.   }
  1154.  
  1155.   return $new;
  1156. }
  1157.  
  1158. =item HTML::Element->clone_list(...nodes...)
  1159.  
  1160. =item or: ref($h)->clone_list(...nodes...)
  1161.  
  1162. Returns a list consisting of a copy of each node given.
  1163. Text segments are simply copied; elements are cloned by
  1164. calling $it->clone on each of them.
  1165.  
  1166. =cut
  1167.  
  1168. sub clone_list {
  1169.   Carp::croak "I can be called only as a class method" if ref shift @_;
  1170.   
  1171.    # all that does is get me here
  1172.   return
  1173.     map
  1174.       {
  1175.         ref($_)
  1176.           ? $_->clone   # copy by method
  1177.           : $_  # copy by evaluation
  1178.       }
  1179.       @_
  1180.   ;
  1181. }
  1182.  
  1183.  
  1184. =item $h->normalize_content
  1185.  
  1186. Normalizes the content of $h -- i.e., concatenates any adjacent text nodes.
  1187. (Any undefined text segments are turned into empty-strings.)
  1188. Note that this does not recurse into $h's descendants.
  1189.  
  1190. =cut
  1191.  
  1192. sub normalize_content {
  1193.   my $start = $_[0];
  1194.   my $c;
  1195.   return unless $c = $start->{'_content'} and ref $c and @$c; # nothing to do
  1196.   # TODO: if we start having text elements, deal with catenating those too?
  1197.   my @stretches = (undef); # start with a barrier
  1198.  
  1199.   # I suppose this could be rewritten to treat stretches as it goes, instead
  1200.   #  of at the end.  But feh.
  1201.  
  1202.   # Scan:
  1203.   for(my $i = 0; $i < @$c; ++$i) {
  1204.     if(defined $c->[$i] and ref $c->[$i]) { # not a text segment
  1205.       if($stretches[0]) {
  1206.         # put in a barrier
  1207.         if($stretches[0][1] == 1) {
  1208.           #print "Nixing stretch at ", $i-1, "\n";
  1209.           undef $stretches[0]; # nix the previous one-node "stretch"
  1210.         } else {
  1211.           #print "End of stretch at ", $i-1, "\n";
  1212.           unshift @stretches, undef
  1213.         }
  1214.       }
  1215.       # else no need for a barrier
  1216.     } else { # text segment
  1217.       $c->[$i] = '' unless defined $c->[$i];
  1218.       if($stretches[0]) {
  1219.         ++$stretches[0][1]; # increase length
  1220.       } else {
  1221.         #print "New stretch at $i\n";
  1222.         unshift @stretches, [$i,1]; # start and length
  1223.       }
  1224.     }
  1225.   }
  1226.  
  1227.   # Now combine.  Note that @stretches is in reverse order, so the indexes
  1228.   # still make sense as we work our way thru (i.e., backwards thru $c).
  1229.   foreach my $s (@stretches) {
  1230.     if($s and $s->[1] > 1) {
  1231.       #print "Stretch at ", $s->[0], " for ", $s->[1], "\n";
  1232.       $c->[$s->[0]] .= join('', splice(@$c, $s->[0] + 1, $s->[1] - 1))
  1233.         # append the subsequent ones onto the first one.
  1234.     }
  1235.   }
  1236.   return;
  1237. }
  1238.  
  1239. =item $h->delete_ignorable_whitespace()
  1240.  
  1241. This traverses under $h and deletes any text segments that are ignorable
  1242. whitespace.  You should not use this if $h under a 'pre' element.
  1243.  
  1244. =cut
  1245.  
  1246. #==========================================================================
  1247.  
  1248. sub delete_ignorable_whitespace {
  1249.   # This doesn't delete all sorts of whitespace that won't actually
  1250.   #  be used in rendering, tho -- that's up to the rendering application.
  1251.   # For example:
  1252.   #   <input type='text' name='foo'>
  1253.   #     [some whitespace]
  1254.   #   <input type='text' name='bar'>
  1255.   # The WS between the two elements /will/ get used by the renderer.
  1256.   # But here:
  1257.   #   <input type='hidden' name='foo' value='1'>
  1258.   #     [some whitespace]
  1259.   #   <input type='text' name='bar' value='2'>
  1260.   # the WS between them won't be rendered in any way, presumably.
  1261.  
  1262.   #my $Debug = 4;
  1263.   die "delete_ignorable_whitespace can be called only as an object method"
  1264.    unless ref $_[0];
  1265.  
  1266.   print "About to tighten up...\n" if $Debug > 2;
  1267.   my(@to_do) = ($_[0]);  # Start off.
  1268.   my($i, $sibs, $ptag, $this); # scratch for the loop...
  1269.   while(@to_do) {
  1270.     if(
  1271.        ( $ptag = ($this = shift @to_do)->{'_tag'} ) eq 'pre'
  1272.        or $ptag eq 'textarea'
  1273.        or $HTML::Tagset::isCDATA_Parent{$ptag}
  1274.     ) {
  1275.       # block the traversal under those
  1276.        print "Blocking traversal under $ptag\n" if $Debug;
  1277.        next;
  1278.     }
  1279.     next unless($sibs = $this->{'_content'} and @$sibs);
  1280.     for($i = $#$sibs; $i >= 0; --$i) { # work backwards thru the list
  1281.       if(ref $sibs->[$i]) {
  1282.         unshift @to_do, $sibs->[$i];
  1283.         # yes, this happens in pre order -- we're going backwards
  1284.         # thru this sibling list.  I doubt it actually matters, tho.
  1285.         next;
  1286.       }
  1287.       next unless $sibs->[$i] =~ m<^\s+$>s; # it's /all/ whitespace
  1288.     
  1289.       print "Under $ptag whose canTighten ",
  1290.           "value is ", 0 + $HTML::Element::canTighten{$ptag}, ".\n"
  1291.        if $Debug > 3;
  1292.  
  1293.       # It's all whitespace...
  1294.       
  1295.       if($i == 0) {
  1296.         if(@$sibs == 1) { # I'm an only child
  1297.           next unless $HTML::Element::canTighten{$ptag}; # parent
  1298.         } else { # I'm leftmost of many
  1299.           # if either my parent or sib are eligible, I'm good.
  1300.           next unless
  1301.            $HTML::Element::canTighten{$ptag} # parent
  1302.            or
  1303.             (ref $sibs->[1]
  1304.              and $HTML::Element::canTighten{$sibs->[1]{'_tag'}} # right sib
  1305.             );
  1306.         }
  1307.       } elsif ($i == $#$sibs) { # I'm rightmost of many
  1308.         # if either my parent or sib are eligible, I'm good.
  1309.         next unless
  1310.            $HTML::Element::canTighten{$ptag} # parent
  1311.            or
  1312.             (ref $sibs->[$i - 1]
  1313.             and $HTML::Element::canTighten{$sibs->[$i - 1]{'_tag'}} # left sib
  1314.             )
  1315.       } else { # I'm the piggy in the middle
  1316.         # My parent doesn't matter -- it all depends on my sibs
  1317.         next
  1318.           unless
  1319.             ref $sibs->[$i - 1] or ref $sibs->[$i + 1];
  1320.          # if NEITHER sib is a node, quit
  1321.          
  1322.         next if
  1323.           # bailout condition: if BOTH are INeligible nodes
  1324.           #  (as opposed to being text, or being eligible nodes)
  1325.             ref $sibs->[$i - 1]
  1326.             and ref $sibs->[$i + 1]
  1327.             and !$HTML::Element::canTighten{$sibs->[$i - 1]{'_tag'}} # left sib
  1328.             and !$HTML::Element::canTighten{$sibs->[$i + 1]{'_tag'}} # right sib
  1329.         ;
  1330.       }
  1331.       # Unknown tags aren't in canTighten and so AREN'T subject to tightening
  1332.  
  1333.       print "  delendum: child $i of $ptag\n" if $Debug > 3;
  1334.       splice @$sibs, $i, 1;
  1335.     }
  1336.      # end of the loop-over-children
  1337.   }
  1338.    # end of the while loop.
  1339.   
  1340.   return;
  1341. }
  1342.  
  1343. #--------------------------------------------------------------------------
  1344.  
  1345. =item $h->insert_element($element, $implicit)
  1346.  
  1347. Inserts (via push_content) a new element under the element at
  1348. $h->pos().  Then updates $h->pos() to point to the inserted element,
  1349. unless $element is a prototypically empty element like "br", "hr",
  1350. "img", etc.  The new $h->pos() is returned.  This method is useful
  1351. only if your particular tree task involves setting $h->pos.
  1352.  
  1353. =cut
  1354.  
  1355. sub insert_element
  1356. {
  1357.     my($self, $tag, $implicit) = @_;
  1358.     return $self->pos() unless $tag; # noop if nothing to insert
  1359.  
  1360.     my $e;
  1361.     if (ref $tag) {
  1362.         $e = $tag;
  1363.         $tag = $e->tag;
  1364.     } else { # just a tag name -- so make the element
  1365.         $e = ($self->{'_element_class'} || __PACKAGE__)->new($tag);
  1366.     ++($self->{'_element_count'}) if exists $self->{'_element_count'};
  1367.      # undocumented.  see TreeBuilder.
  1368.     }
  1369.  
  1370.     $e->{'_implicit'} = 1 if $implicit;
  1371.  
  1372.     my $pos = $self->{'_pos'};
  1373.     $pos = $self unless defined $pos;
  1374.  
  1375.     $pos->push_content($e);
  1376.  
  1377.     $self->{'_pos'} = $pos = $e
  1378.       unless $self->_empty_element_map->{$tag} || $e->{'_empty_element'};
  1379.  
  1380.     $pos;
  1381. }
  1382.  
  1383. #==========================================================================
  1384. # Some things to override in XML::Element
  1385.  
  1386. sub _empty_element_map {
  1387.   \%HTML::Element::emptyElement;
  1388. }
  1389.  
  1390. sub _fold_case_LC {
  1391.   if(wantarray) {
  1392.     shift;
  1393.     map lc($_), @_;
  1394.   } else {
  1395.     return lc($_[1]);
  1396.   }
  1397. }
  1398.  
  1399. sub _fold_case_NOT {
  1400.   if(wantarray) {
  1401.     shift;
  1402.     @_;
  1403.   } else {
  1404.     return $_[1];
  1405.   }
  1406. }
  1407.  
  1408. *_fold_case = \&_fold_case_LC;
  1409.  
  1410. #==========================================================================
  1411.  
  1412. =back
  1413.  
  1414. =head1 DUMPING METHODS
  1415.  
  1416. =over 4
  1417.  
  1418. =item $h->dump()
  1419.  
  1420. =item $h->dump(*FH)  ; # or *FH{IO} or $fh_obj
  1421.  
  1422. Prints the element and all its children to STDOUT (or to a specified
  1423. filehandle), in a format useful
  1424. only for debugging.  The structure of the document is shown by
  1425. indentation (no end tags).
  1426.  
  1427. =cut
  1428.  
  1429. sub dump
  1430. {
  1431.     my($self, $fh, $depth) = @_;
  1432.     $fh = *STDOUT{IO} unless defined $fh;
  1433.     $depth = 0 unless defined $depth;
  1434.     print $fh
  1435.       "  " x $depth,   $self->starttag,   " \@", $self->address,
  1436.       $self->{'_implicit'} ? " (IMPLICIT)\n" : "\n";
  1437.     for (@{$self->{'_content'}}) {
  1438.         if (ref $_) {  # element
  1439.             $_->dump($fh, $depth+1);  # recurse
  1440.         } else {  # text node
  1441.             print $fh "  " x ($depth + 1);
  1442.             if(length($_) > 65 or m<[\x00-\x1F]>) {
  1443.               # it needs prettyin' up somehow or other
  1444.               my $x = (length($_) <= 65) ? $_ : (substr($_,0,65) . '...');
  1445.               $x =~ s<([\x00-\x1F])>
  1446.                      <'\\x'.(unpack("H2",$1))>eg;
  1447.               print $fh qq{"$x"\n};
  1448.             } else {
  1449.               print $fh qq{"$_"\n};
  1450.             }
  1451.         }
  1452.     }
  1453. }
  1454.  
  1455.  
  1456. =item $h->as_HTML() or $h->as_HTML($entities)
  1457.  
  1458. =item or $h->as_HTML($entities, $indent_char)
  1459.  
  1460. =item or $h->as_HTML($entities, $indent_char, \%optional_end_tags)
  1461.  
  1462. Returns a string representing in HTML the element and its
  1463. descendants.  The optional argument C<$entities> specifies a string of
  1464. the entities to encode.  For compatibility with previous versions,
  1465. specify C<'E<lt>E<gt>&'> here.  If omitted or undef, I<all> unsafe
  1466. characters are encoded as HTML entities.  See L<HTML::Entities> for
  1467. details.
  1468.  
  1469. If $indent_char is specified and defined, the HTML to be output is
  1470. intented, using the string you specify (which you probably should
  1471. set to "\t", or some number of spaces, if you specify it).
  1472.  
  1473. If C<\%optional_end_tags> is specified and defined, it should be
  1474. a reference to a hash that holds a true value for every tag name
  1475. whose end tag is optional.  Defaults to
  1476. C<\%HTML::Element::optionalEndTag>, which is an alias to
  1477. C<%HTML::Tagset::optionalEndTag>, which, at time of writing, contains
  1478. true values for C<p, li, dt, dd>.  A useful value to pass is an empty
  1479. hashref, C<{}>, which means that no end-tags are optional for this dump.
  1480. Otherwise, possibly consider copying C<%HTML::Tagset::optionalEndTag> to a
  1481. hash of your own, adding or deleting values as you like, and passing
  1482. a reference to that hash.
  1483.  
  1484. =cut
  1485.  
  1486. sub as_HTML {
  1487.   my($self, $entities, $indent, $omissible_map) = @_;
  1488.   #my $indent_on = defined($indent) && length($indent);
  1489.   my @html = ();
  1490.  
  1491.   undef($entities) unless defined($entities) and length($entities);
  1492.  
  1493.   $omissible_map ||= \%HTML::Element::optionalEndTag;
  1494.   my $empty_element_map = $self->_empty_element_map;
  1495.  
  1496.   my $last_tag_tightenable = 0;
  1497.   my $this_tag_tightenable = 0;
  1498.   my $nonindentable_ancestors = 0;  # count of nonindentible tags over us.
  1499.   
  1500.   my($tag, $node, $start, $depth); # per-iteration scratch
  1501.   
  1502.   if(defined($indent) && length($indent)) {
  1503.     $self->traverse(
  1504.       sub {
  1505.         ($node, $start, $depth) = @_;
  1506.         if(ref $node) { # it's an element
  1507.            
  1508.            $tag = $node->{'_tag'};
  1509.            
  1510.            if($start) { # on the way in
  1511.              if(
  1512.                 ($this_tag_tightenable = $HTML::Element::canTighten{$tag})
  1513.                 and !$nonindentable_ancestors
  1514.                 and $last_tag_tightenable
  1515.              ) {
  1516.                push
  1517.                  @html,
  1518.                  "\n",
  1519.                  $indent x $depth,
  1520.                  $node->starttag($entities),
  1521.                ;
  1522.              } else {
  1523.                push(@html, $node->starttag($entities));
  1524.              }
  1525.              $last_tag_tightenable = $this_tag_tightenable;
  1526.              
  1527.              ++$nonindentable_ancestors
  1528.                if $tag eq 'pre' or $HTML::Tagset::isCDATA_Parent{$tag};             ;
  1529.              
  1530.            } elsif (not($empty_element_map->{$tag} or $omissible_map->{$tag})) {
  1531.              # on the way out
  1532.              if($tag eq 'pre' or $HTML::Tagset::isCDATA_Parent{$tag}) {
  1533.                --$nonindentable_ancestors;
  1534.                $last_tag_tightenable = $HTML::Element::canTighten{$tag};
  1535.                push @html, $node->endtag;
  1536.                
  1537.              } else { # general case
  1538.                if(
  1539.                   ($this_tag_tightenable = $HTML::Element::canTighten{$tag})
  1540.                   and !$nonindentable_ancestors
  1541.                   and $last_tag_tightenable
  1542.                ) {
  1543.                  push
  1544.                    @html,
  1545.                    "\n",
  1546.                    $indent x $depth,
  1547.                    $node->endtag,
  1548.                  ;
  1549.                } else {
  1550.                  push @html, $node->endtag;
  1551.                }
  1552.                $last_tag_tightenable = $this_tag_tightenable;
  1553.                #print "$tag tightenable: $this_tag_tightenable\n";
  1554.              }
  1555.            }
  1556.         } else {  # it's a text segment
  1557.         
  1558.           $last_tag_tightenable = 0;  # I guess this is right
  1559.           HTML::Entities::encode_entities($node, $entities)
  1560.             # That does magic things if $entities is undef.
  1561.            unless $HTML::Tagset::isCDATA_Parent{ $_[3]{'_tag'} };
  1562.             # To keep from amp-escaping children of script et al.
  1563.             # That doesn't deal with descendants; but then, CDATA
  1564.             #  parents shouldn't /have/ descendants other than a
  1565.             #  text children (or comments?)
  1566.           if($nonindentable_ancestors) {
  1567.             push @html, $node; # say no go
  1568.           } else {
  1569.             if($last_tag_tightenable) {
  1570.               $node =~ s<\s+>< >s;
  1571.               #$node =~ s< $><>s;
  1572.               $node =~ s<^ ><>s;
  1573.               push
  1574.                 @html,
  1575.                 "\n",
  1576.                 $indent x $depth,
  1577.                 $node,
  1578.                 #Text::Wrap::wrap($indent x $depth, $indent x $depth, "\n" . $node)
  1579.               ;
  1580.             } else {
  1581.               push
  1582.                 @html,
  1583.                 $node,
  1584.                 #Text::Wrap::wrap('', $indent x $depth, $node)
  1585.               ;
  1586.             }
  1587.           }
  1588.         }
  1589.         1; # keep traversing
  1590.       }
  1591.     );
  1592.     
  1593.   } else { # no indenting -- much simpler code
  1594.     $self->traverse(
  1595.       sub {
  1596.           ($node, $start) = @_;
  1597.           if(ref $node) {
  1598.             $tag = $node->{'_tag'};
  1599.             if($start) { # on the way in
  1600.               push(@html, $node->starttag($entities));
  1601.             } elsif (not($empty_element_map->{$tag} or $omissible_map->{$tag})) {
  1602.               # on the way out
  1603.               push(@html, $node->endtag);
  1604.             }
  1605.           } else {
  1606.             # simple text content
  1607.             HTML::Entities::encode_entities($node, $entities)
  1608.               # That does magic things if $entities is undef.
  1609.              unless $HTML::Tagset::isCDATA_Parent{ $_[3]{'_tag'} };
  1610.               # To keep from amp-escaping children of script et al.
  1611.               # That doesn't deal with descendants; but then, CDATA
  1612.               #  parents shouldn't /have/ descendants other than a
  1613.               #  text children (or comments?)
  1614.             push(@html, $node);
  1615.           }
  1616.          1; # keep traversing
  1617.         }
  1618.     );
  1619.   }
  1620.   
  1621.   join('', @html, "\n");
  1622. }
  1623.  
  1624.  
  1625. =item $h->as_text()
  1626.  
  1627. =item $h->as_text(skip_dels => 1)
  1628.  
  1629. Returns a string consisting of only the text parts of the element's
  1630. descendants.
  1631.  
  1632. Text under 'script' or 'style' elements is never included in what's
  1633. returned.  If C<skip_dels> is true, then text content under "del"
  1634. nodes is not included in what's returned.
  1635.  
  1636. =item $h->as_trimmed_text(...)
  1637.  
  1638. This is just like as_text(...) except that leading and trailing
  1639. whitespace is deleted, and any internal whitespace is collapsed.
  1640.  
  1641. =cut
  1642.  
  1643. sub as_text {
  1644.   # Yet another iteratively implemented traverser
  1645.   my($this,%options) = @_;
  1646.   my $skip_dels = $options{'skip_dels'} || 0;
  1647.   #print "Skip dels: $skip_dels\n";
  1648.   my(@pile) = ($this);
  1649.   my $tag;
  1650.   my $text = '';
  1651.   while(@pile) {
  1652.     if(!defined($pile[0])) { # undef!
  1653.       # no-op
  1654.     } elsif(!ref($pile[0])) { # text bit!  save it!
  1655.       $text .= shift @pile;
  1656.     } else { # it's a ref -- traverse under it
  1657.       unshift @pile, @{$this->{'_content'} || $nillio}
  1658.         unless
  1659.           ($tag = ($this = shift @pile)->{'_tag'}) eq 'style'
  1660.           or $tag eq 'script'
  1661.           or ($skip_dels and $tag eq 'del');
  1662.     }
  1663.   }
  1664.   return $text;
  1665. }
  1666.  
  1667. sub as_trimmed_text {
  1668.   my $text = shift->as_text(@_);
  1669.   $text =~ s/\s+$//s;
  1670.   $text =~ s/^\s+//s;
  1671.   $text =~ s/\s+/ /g;
  1672.   return $text;
  1673. }
  1674.  
  1675. sub as_text_trimmed { shift->as_trimmed_text(@_) } # alias, because I forget
  1676.  
  1677. =item $h->as_XML()
  1678.  
  1679. Returns a string representing in XML the element and its descendants.
  1680.  
  1681. The XML is not indented.
  1682.  
  1683. =cut
  1684.  
  1685. # TODO: make it wrap, if not indent?
  1686.  
  1687. sub as_XML {
  1688.   # based an as_HTML
  1689.   my($self) = @_;
  1690.   #my $indent_on = defined($indent) && length($indent);
  1691.   my @xml = ();
  1692.   my $empty_element_map = $self->_empty_element_map;
  1693.   
  1694.   my($tag, $node, $start); # per-iteration scratch
  1695.   $self->traverse(
  1696.     sub {
  1697.         ($node, $start) = @_;
  1698.         if(ref $node) { # it's an element
  1699.           $tag = $node->{'_tag'};
  1700.           if($start) { # on the way in
  1701.             if($empty_element_map->{$tag}
  1702.                and !@{$node->{'_content'} || $nillio}
  1703.             ) {
  1704.               push(@xml, $node->starttag_XML(undef,1));
  1705.             } else {
  1706.               push(@xml, $node->starttag_XML(undef));
  1707.             }
  1708.           } else { # on the way out
  1709.             unless($empty_element_map->{$tag}
  1710.                    and !@{$node->{'_content'} || $nillio}
  1711.             ) {
  1712.               push(@xml, $node->endtag_XML());
  1713.             } # otherwise it will have been an <... /> tag.
  1714.           }
  1715.         } else { # it's just text
  1716.           _xml_escape($node);
  1717.           push(@xml, $node);
  1718.         }
  1719.        1; # keep traversing
  1720.       }
  1721.   );
  1722.   
  1723.   join('', @xml, "\n");
  1724. }
  1725.  
  1726.  
  1727. sub _xml_escape {  # DESTRUCTIVE (a.k.a. "in-place")
  1728.   foreach my $x (@_) {
  1729.     $x =~ s<([^\x20\x21\x23\x27-\x3b\x3d\x3F-\x5B\x5D-\x7E])>
  1730.            <'&#'.(ord($1)).';'>seg;
  1731.   }
  1732.   return;
  1733. }
  1734.  
  1735. =item $h->as_Lisp_form()
  1736.  
  1737. Returns a string representing the element and its descendants as a
  1738. Lisp form.  Unsafe characters are encoded as octal escapes.
  1739.  
  1740. The Lisp form is indented, and contains external ("href", etc.)  as
  1741. well as internal attributes ("_tag", "_content", "_implicit", etc.),
  1742. except for "_parent", which is omitted.
  1743.  
  1744. Current example output for a given element:
  1745.  
  1746.   ("_tag" "img" "border" "0" "src" "pie.png" "usemap" "#main.map")
  1747.  
  1748. =cut
  1749.  
  1750. # NOTES:
  1751. #
  1752. # It's been suggested that attribute names be made :-keywords:
  1753. #   (:_tag "img" :border 0 :src "pie.png" :usemap "#main.map")
  1754. # However, it seems that Scheme has no such data type as :-keywords.
  1755. # So, for the moment at least, I tend toward simplicity, uniformity,
  1756. #  and universality, where everything a string or a list.
  1757.  
  1758. sub as_Lisp_form {
  1759.   my @out;
  1760.   
  1761.   my $sub;
  1762.   my $depth = 0;
  1763.   my(@list, $val);
  1764.   $sub = sub {  # Recursor
  1765.     my $self = $_[0];
  1766.     @list = ('_tag', $self->{'_tag'});
  1767.     @list = () unless defined $list[-1]; # unlikely
  1768.     
  1769.     for (sort keys %$self) { # predictable ordering
  1770.       next if $_ eq '_content' or $_ eq '_tag' or $_ eq '_parent' or $_ eq '/';
  1771.        # Leave the other private attributes, I guess.
  1772.       push @list, $_, $val if defined($val = $self->{$_}); # and !ref $val;
  1773.     }
  1774.     
  1775.     for (@list) {
  1776.       #if(!length $_) {
  1777.       #  $_ = '""';
  1778.       #} elsif(
  1779.       #  $_ eq '0'
  1780.       #  or (
  1781.       #     m/^-?\d+(\.\d+)?$/s
  1782.       #     and $_ ne '-0' # the strange case that that RE lets thru
  1783.       #  ) or (
  1784.       #     m/^-?\.\d+$/s
  1785.       #  )
  1786.       #) {
  1787.       #  # No-op -- don't bother quoting numbers.
  1788.       #  # Note: DOES accept strings like "0123" and ".123" as numbers!
  1789.       #  #  
  1790.       #} else {
  1791.         # octal-escape it
  1792.         s<([^\x20\x21\x23\x27-\x5B\x5D-\x7E])>
  1793.          <sprintf('\\%03o',ord($1))>eg;
  1794.         $_ = qq{"$_"};
  1795.       #}
  1796.     }
  1797.     
  1798.     push @out, ('  ' x $depth) . '(' . join ' ', splice @list;
  1799.     if(@{$self->{'_content'} || $nillio}) {
  1800.       $out[-1] .= " \"_content\" (\n";
  1801.       ++$depth;
  1802.       foreach my $c (@{$self->{'_content'}}) {
  1803.         if(ref($c)) {
  1804.           # an element -- recurse
  1805.           $sub->($c);
  1806.         } else {
  1807.           # a text segment -- stick it in and octal-escape it
  1808.           push @out, $c;
  1809.           $out[-1] =~
  1810.             s<([^\x20\x21\x23\x27-\x5B\x5D-\x7E])>
  1811.              <sprintf('\\%03o',ord($1))>eg;
  1812.           # And quote and indent it.
  1813.           $out[-1] .= "\"\n";
  1814.           $out[-1] = ('  ' x $depth) . '"' . $out[-1];
  1815.         }
  1816.       }
  1817.       --$depth;
  1818.       substr($out[-1],-1) = "))\n"; # end of _content and of the element
  1819.     } else {
  1820.       $out[-1] .= ")\n";
  1821.     }
  1822.     return;
  1823.   };
  1824.   
  1825.   $sub->($_[0]);
  1826.   undef $sub;
  1827.   return join '', @out;
  1828. }
  1829.  
  1830.  
  1831. sub format
  1832. {
  1833.     my($self, $formatter) = @_;
  1834.     unless (defined $formatter) {
  1835.         require HTML::FormatText;
  1836.         $formatter = HTML::FormatText->new();
  1837.     }
  1838.     $formatter->format($self);
  1839. }
  1840.  
  1841.  
  1842.  
  1843. =item $h->starttag() or $h->starttag($entities)
  1844.  
  1845. Returns a string representing the complete start tag for the element.
  1846. I.e., leading "<", tag name, attributes, and trailing ">".  Attributes
  1847. values that don't consist entirely of digits are surrounded with
  1848. double-quotes, and appropriate characters are encoded.  If C<$entities>
  1849. is omitted or undef, I<all> unsafe characters are encoded as HTML
  1850. entities.  See L<HTML::Entities> for details.  If you specify some
  1851. value for C<$entities>, remember to include the double-quote character in
  1852. it.  (Previous versions of this module would basically behave as if
  1853. C<'&"E<gt>'> were specified for C<$entities>.)
  1854.  
  1855. =cut
  1856.  
  1857. sub starttag
  1858. {
  1859.     my($self, $entities) = @_;
  1860.     
  1861.     my $name = $self->{'_tag'};
  1862.     
  1863.     return        $self->{'text'}        if $name eq '~literal';
  1864.     
  1865.     return "<!" . $self->{'text'} . ">"  if $name eq '~declaration';
  1866.     
  1867.     return "<?" . $self->{'text'} . ">"  if $name eq '~pi';
  1868.     
  1869.     if($name eq '~comment') {
  1870.       if(ref($self->{'text'} || '') eq 'ARRAY') {
  1871.         # Does this ever get used?  And is this right?
  1872.         return 
  1873.           "<!" .
  1874.           join(' ', map("--$_--", @{$self->{'text'}}))
  1875.           .  ">"
  1876.        ;
  1877.       } else {
  1878.         return "<!--" . $self->{'text'} . "-->"
  1879.       }
  1880.     }
  1881.     
  1882.     my $tag = $html_uc ? "<\U$name" : "<\L$name";
  1883.     my $val;
  1884.     for (sort keys %$self) { # predictable ordering
  1885.         next if !length $_ or m/^_/s or $_ eq '/';
  1886.         $val = $self->{$_};
  1887.         next if !defined $val; # or ref $val;
  1888.         if ($_ eq $val &&   # if attribute is boolean, for this element
  1889.             exists($HTML::Element::boolean_attr{$name}) &&
  1890.             (ref($HTML::Element::boolean_attr{$name})
  1891.               ? $HTML::Element::boolean_attr{$name}{$_}
  1892.               : $HTML::Element::boolean_attr{$name} eq $_)
  1893.         ) {
  1894.             $tag .= $html_uc ? " \U$_" : " \L$_";
  1895.         } else { # non-boolean attribute
  1896.             if ($val !~ m/^[0-9]+$/s) { # quote anything not purely numeric
  1897.               # Might as well double-quote everything, for simplicity's sake
  1898.               HTML::Entities::encode_entities($val, $entities);
  1899.               $val = qq{"$val"};
  1900.             }
  1901.             $tag .= $html_uc ? qq{ \U$_\E=$val} : qq{ \L$_\E=$val};
  1902.         }
  1903.     }
  1904.     "$tag>";
  1905. }
  1906.  
  1907.  
  1908. # TODO: document?
  1909. sub starttag_XML
  1910. {
  1911.     my($self) = @_;
  1912.      # and a third parameter to signal emptiness?
  1913.     
  1914.     my $name = $self->{'_tag'};
  1915.     
  1916.     return        $self->{'text'}        if $name eq '~literal';
  1917.     
  1918.     return '<!' . $self->{'text'}. '>'   if $name eq '~declaration';
  1919.     
  1920.     return "<?" . $self->{'text'} . "?>" if $name eq '~pi';
  1921.     
  1922.     if($name eq '~comment') {
  1923.       
  1924.       if(ref($self->{'text'} || '') eq 'ARRAY') {
  1925.         # Does this ever get used?  And is this right?
  1926.         $name = join(' ', @{$self->{'text'}});
  1927.       } else {
  1928.         $name = $self->{'text'};
  1929.       }
  1930.       $name =~ s/--/--/g; # can't have double --'s in XML comments
  1931.       return "<!-- $name -->";
  1932.     }
  1933.     
  1934.     my $tag = "<$name";
  1935.     my $val;
  1936.     for (sort keys %$self) { # predictable ordering
  1937.         next if !length $_ or  m/^_/s or $_ eq '/';
  1938.         # Hm -- what to do if val is undef?
  1939.         # I suppose that shouldn't ever happen.
  1940.         next if !defined($val = $self->{$_}); # or ref $val;
  1941.         _xml_escape($val);
  1942.         $tag .= qq{ $_="$val"};
  1943.     }
  1944.     @_ == 3 ? "$tag />" : "$tag>";
  1945. }
  1946.  
  1947.  
  1948.  
  1949. =item $h->endtag()
  1950.  
  1951. Returns a string representing the complete end tag for this element.
  1952. I.e., "</", tag name, and ">".
  1953.  
  1954. =cut
  1955.  
  1956. sub endtag
  1957. {
  1958.     $html_uc ? "</\U$_[0]->{'_tag'}>" : "</\L$_[0]->{'_tag'}>";
  1959. }
  1960.  
  1961. # TODO: document?
  1962. sub endtag_XML
  1963. {
  1964.     "</$_[0]->{'_tag'}>";
  1965. }
  1966.  
  1967.  
  1968. #==========================================================================
  1969. # This, ladies and germs, is an iterative implementation of a
  1970. # recursive algorithm.  DON'T TRY THIS AT HOME.
  1971. # Basically, the algorithm says:
  1972. #
  1973. # To traverse:
  1974. #   1: pre-order visit this node
  1975. #   2: traverse any children of this node
  1976. #   3: post-order visit this node, unless it's a text segment,
  1977. #       or a prototypically empty node (like "br", etc.)
  1978. # Add to that the consideration of the callbacks' return values,
  1979. # so you can block visitation of the children, or siblings, or
  1980. # abort the whole excursion, etc.
  1981. #
  1982. # So, why all this hassle with making the code iterative?
  1983. # It makes for real speed, because it eliminates the whole
  1984. # hassle of Perl having to allocate scratch space for each
  1985. # instance of the recursive sub.  Since the algorithm
  1986. # is basically simple (and not all recursive ones are!) and
  1987. # has few necessary lexicals (basically just the current node's
  1988. # content list, and the current position in it), it was relatively
  1989. # straightforward to store that information not as the frame
  1990. # of a sub, but as a stack, i.e., a simple Perl array (well, two
  1991. # of them, actually: one for content-listrefs, one for indexes of
  1992. # current position in each of those).
  1993.  
  1994. my $NIL = [];
  1995. sub traverse {
  1996.   my($start, $callback, $ignore_text) = @_;
  1997.  
  1998.   Carp::croak "traverse can be called only as an object method"
  1999.    unless ref $start;
  2000.   
  2001.   Carp::croak('must provide a callback for traverse()!')
  2002.    unless defined $callback and ref $callback;
  2003.   
  2004.   # Elementary type-checking:
  2005.   my($c_pre, $c_post);
  2006.   if(UNIVERSAL::isa($callback, 'CODE')) {
  2007.     $c_pre = $c_post = $callback;
  2008.   } elsif(UNIVERSAL::isa($callback,'ARRAY')) {
  2009.     ($c_pre, $c_post) = @$callback;
  2010.     Carp::croak("pre-order callback \"$c_pre\" is true but not a coderef!")
  2011.      if $c_pre and not UNIVERSAL::isa($c_pre, 'CODE');
  2012.     Carp::croak("pre-order callback \"$c_post\" is true but not a coderef!")
  2013.      if $c_post and not UNIVERSAL::isa($c_post, 'CODE');
  2014.     return $start unless $c_pre or $c_post;
  2015.      # otherwise there'd be nothing to actually do!
  2016.   } else {
  2017.     Carp::croak("$callback is not a known kind of reference")
  2018.      unless ref($callback);
  2019.   }
  2020.   
  2021.   my $empty_element_map = $start->_empty_element_map;
  2022.   
  2023.   my(@C) = [$start]; # a stack containing lists of children
  2024.   my(@I) = (-1); # initial value must be -1 for each list
  2025.     # a stack of indexes to current position in corresponding lists in @C
  2026.   # In each of these, 0 is the active point
  2027.   
  2028.   # scratch:
  2029.   my(
  2030.     $rv,   # return value of callback
  2031.     $this, # current node
  2032.     $content_r, # child list of $this
  2033.   );
  2034.   
  2035.   
  2036.   # THE BIG LOOP
  2037.   while(@C) {
  2038.     # Move to next item in this frame
  2039.     #print "Loop: \@C has ", scalar(@C), " frames: @C\n";
  2040.     if(!defined($I[0]) or ++$I[0] >= @{$C[0]}) {
  2041.       # We either went off the end of this list, or aborted the list
  2042.       # So call the post-order callback:
  2043.       if($c_post
  2044.          and defined $I[0]
  2045.          and @C > 1
  2046.           # to keep the next line from autovivifying
  2047.          and defined($this = $C[1][ $I[1] ]) # sanity, and
  2048.           # suppress callbacks on exiting the fictional top frame
  2049.          and ref($this) # sanity
  2050.          and not(
  2051.                  $this->{'_empty_element'}
  2052.                  || $empty_element_map->{$this->{'_tag'} || ''}
  2053.                 ) # things that don't get post-order callbacks
  2054.       ) {
  2055.         shift @I;
  2056.         shift @C;
  2057.         #print "Post! at depth", scalar(@I), "\n";
  2058.         $rv = $c_post->(
  2059.            #map $_, # copy to avoid any messiness
  2060.            $this,           # 0: this
  2061.            0,               # 1: startflag (0 for post-order call)
  2062.            @I - 1,          # 2: depth
  2063.         );
  2064.         
  2065.         if(defined($rv) and ref($rv) eq $travsignal_package) {
  2066.           $rv = $$rv; #deref
  2067.           if($rv eq 'ABORT') {
  2068.             last; # end of this excursion!
  2069.           } elsif($rv eq 'PRUNE') {
  2070.             # NOOP on post!!
  2071.           } elsif($rv eq 'PRUNE_SOFTLY') {
  2072.             # NOOP on post!!
  2073.           } elsif($rv eq 'OK') {
  2074.             # noop
  2075.           } elsif($rv eq 'PRUNE_UP') {
  2076.             $I[0] = undef;
  2077.           } else {
  2078.             die "Unknown travsignal $rv\n";
  2079.             # should never happen
  2080.           }
  2081.         }
  2082.         
  2083.       } else {
  2084.         #print "Oomph.  Callback suppressed\n";
  2085.         shift @I;
  2086.         shift @C;
  2087.       }
  2088.       next;
  2089.     }
  2090.     
  2091.     $this = $C[0][ $I[0] ];
  2092.     
  2093.     if($c_pre) {
  2094.       if(defined $this and ref $this) { # element
  2095.         $rv = $c_pre->(
  2096.            #map $_, # copy to avoid any messiness
  2097.            $this,           # 0: this
  2098.            1,               # 1: startflag (1 for pre-order call)
  2099.            @I - 1,          # 2: depth
  2100.         );
  2101.       } else { # text segment
  2102.         next if $ignore_text;
  2103.         $rv = $c_pre->(
  2104.            #map $_, # copy to avoid any messiness
  2105.            $this,           # 0: this
  2106.            1,               # 1: startflag (1 for pre-order call)
  2107.            @I - 1,          # 2: depth
  2108.            $C[1][ $I[1] ],  # 3: parent
  2109.                # And there will always be a $C[1], since
  2110.                #  we can't start traversing at a text node
  2111.            $I[0]            # 4: index of self in parent's content list
  2112.         );
  2113.       }
  2114.       if(not $rv) { # returned false.  Same as PRUNE.
  2115.         next; # prune
  2116.       } elsif(ref($rv) eq $travsignal_package) {
  2117.         $rv = $$rv; # deref
  2118.         if($rv eq 'ABORT') {
  2119.           last; # end of this excursion!
  2120.         } elsif($rv eq 'PRUNE') {
  2121.           next;
  2122.         } elsif($rv eq 'PRUNE_SOFTLY') {
  2123.           if(ref($this)
  2124.              and
  2125.              not($this->{'_empty_element'}
  2126.                  || $empty_element_map->{$this->{'_tag'} || ''})
  2127.           ) {
  2128.             # push a dummy empty content list just to trigger a post callback
  2129.             unshift @I, -1;
  2130.             unshift @C, $NIL;
  2131.           }
  2132.           next;
  2133.         } elsif($rv eq 'OK') {
  2134.           # noop
  2135.         } elsif($rv eq 'PRUNE_UP') {
  2136.           $I[0] = undef;
  2137.           next;
  2138.           
  2139.           # equivalent of last'ing out of the current child list.
  2140.           
  2141.         # Used to have PRUNE_UP_SOFTLY and ABORT_SOFTLY here, but the code
  2142.         # for these was seriously upsetting, served no particularly clear
  2143.         # purpose, and could not, I think, be easily implemented with a
  2144.         # recursive routine.  All bad things!
  2145.         } else {
  2146.           die "Unknown travsignal $rv\n";
  2147.           # should never happen
  2148.         }
  2149.       }
  2150.       # else fall thru to meaning same as \'OK'.
  2151.     }
  2152.     # end of pre-order calling
  2153.     
  2154.     # Now queue up content list for the current element...
  2155.     if(ref $this
  2156.        and
  2157.        not( # ...except for those which...
  2158.          not($content_r = $this->{'_content'} and @$content_r)
  2159.             # ...have empty content lists...
  2160.          and $this->{'_empty_element'} || $empty_element_map->{$this->{'_tag'} || ''}
  2161.             # ...and that don't get post-order callbacks
  2162.        )
  2163.     ) {
  2164.       unshift @I, -1;
  2165.       unshift @C, $content_r || $NIL;
  2166.       #print $this->{'_tag'}, " ($this) adds content_r ", $C[0], "\n";
  2167.     }
  2168.   }
  2169.   return $start;
  2170. }
  2171.  
  2172.  
  2173. =back
  2174.  
  2175. =head1 SECONDARY STRUCTURAL METHODS
  2176.  
  2177. These methods all involve some structural aspect of the tree;
  2178. either they report some aspect of the tree's structure, or they involve
  2179. traversal down the tree, or walking up the tree.
  2180.  
  2181. =over 4
  2182.  
  2183. =item $h->is_inside('tag', ...) or $h->is_inside($element, ...)
  2184.  
  2185. Returns true if the $h element is, or is contained anywhere inside an
  2186. element that is any of the ones listed, or whose tag name is any of
  2187. the tag names listed.
  2188.  
  2189. =cut
  2190.  
  2191. sub is_inside {
  2192.   my $self = shift;
  2193.   return undef unless @_; # if no items specified, I guess this is right.
  2194.  
  2195.   my $current = $self;
  2196.       # the loop starts by looking at the given element
  2197.   while (defined $current and ref $current) {
  2198.     for (@_) {
  2199.       if(ref) { # element
  2200.         return 1 if $_ eq $current;
  2201.       } else { # tag name
  2202.         return 1 if $_ eq $current->{'_tag'};
  2203.       }
  2204.     }
  2205.     $current = $current->{'_parent'};
  2206.   }
  2207.   0;
  2208. }
  2209.  
  2210. =item $h->is_empty()
  2211.  
  2212. Returns true if $h has no content, i.e., has no elements or text
  2213. segments under it.  In other words, this returns true if $h is a leaf
  2214. node, AKA a terminal node.  Do not confuse this sense of "empty" with
  2215. another sense that it can have in SGML/HTML/XML terminology, which
  2216. means that the element in question is of the type (like HTML's "hr",
  2217. "br", "img", etc.) that I<can't> have any content.
  2218.  
  2219. That is, a particular "p" element may happen to have no content, so
  2220. $that_p_element->is_empty will be true -- even though the prototypical
  2221. "p" element isn't "empty" (not in the way that the prototypical "hr"
  2222. element is).
  2223.  
  2224. If you think this might make for potentially confusing code, consider
  2225. simply using the clearer exact equivalent:  not($h->content_list)
  2226.  
  2227. =cut
  2228.  
  2229. sub is_empty
  2230. {
  2231.   my $self = shift;
  2232.   !$self->{'_content'} || !@{$self->{'_content'}};
  2233. }
  2234.  
  2235.  
  2236. =item $h->pindex()
  2237.  
  2238. Return the index of the element in its parent's contents array, such
  2239. that $h would equal
  2240.  
  2241.   $h->parent->content->[$h->pindex]
  2242.   or
  2243.   ($h->parent->content_list)[$h->pindex]
  2244.  
  2245. assuming $h isn't root.  If the element $h is root, then
  2246. $h->pindex returns undef.
  2247.  
  2248. =cut
  2249.  
  2250. #'
  2251. sub pindex {
  2252.   my $self = shift;
  2253.  
  2254.   my $parent = $self->{'_parent'} || return undef;
  2255.   my $pc =  $parent->{'_content'} || return undef;
  2256.   for(my $i = 0; $i < @$pc; ++$i) {
  2257.     return $i  if  ref $pc->[$i] and $pc->[$i] eq $self;
  2258.   }
  2259.   return undef; # we shouldn't ever get here
  2260. }
  2261.  
  2262. #--------------------------------------------------------------------------
  2263.  
  2264. =item $h->left()
  2265.  
  2266. In scalar context: returns the node that's the immediate left sibling
  2267. of $h.  If $h is the leftmost (or only) child of its parent (or has no
  2268. parent), then this returns undef.
  2269.  
  2270. In list context: returns all the nodes that're the left siblings of $h
  2271. (starting with the leftmost).  If $h is the leftmost (or only) child
  2272. of its parent (or has no parent), then this returns empty-list.
  2273.  
  2274. (See also $h->preinsert(LIST).)
  2275.  
  2276. =cut
  2277.  
  2278. sub left {
  2279.   Carp::croak "left() is supposed to be an object method"
  2280.    unless ref $_[0];
  2281.   my $pc =
  2282.     (
  2283.      $_[0]->{'_parent'} || return
  2284.     )->{'_content'} || die "parent is childless?";
  2285.  
  2286.   die "parent is childless" unless @$pc;
  2287.   return if @$pc == 1; # I'm an only child
  2288.  
  2289.   if(wantarray) {
  2290.     my @out;
  2291.     foreach my $j (@$pc) {
  2292.       return @out if ref $j and $j eq $_[0];
  2293.       push @out, $j;
  2294.     }
  2295.   } else {
  2296.     for(my $i = 0; $i < @$pc; ++$i) {
  2297.       return $i ? $pc->[$i - 1] : undef
  2298.        if ref $pc->[$i] and $pc->[$i] eq $_[0];
  2299.     }
  2300.   }
  2301.  
  2302.   die "I'm not in my parent's content list?";
  2303.   return;
  2304. }
  2305.  
  2306. =item $h->right()
  2307.  
  2308. In scalar context: returns the node that's the immediate right sibling
  2309. of $h.  If $h is the rightmost (or only) child of its parent (or has
  2310. no parent), then this returns undef.
  2311.  
  2312. In list context: returns all the nodes that're the right siblings of
  2313. $h, starting with the leftmost.  If $h is the rightmost (or only) child
  2314. of its parent (or has no parent), then this returns empty-list.
  2315.  
  2316. (See also $h->postinsert(LIST).)
  2317.  
  2318. =cut
  2319.  
  2320. sub right {
  2321.   Carp::croak "right() is supposed to be an object method"
  2322.    unless ref $_[0];
  2323.   my $pc =
  2324.     (
  2325.      $_[0]->{'_parent'} || return
  2326.     )->{'_content'} || die "parent is childless?";
  2327.  
  2328.   die "parent is childless" unless @$pc;
  2329.   return if @$pc == 1; # I'm an only child
  2330.  
  2331.   if(wantarray) {
  2332.     my(@out, $seen);
  2333.     foreach my $j (@$pc) {
  2334.       if($seen) {
  2335.         push @out, $j;
  2336.       } else {
  2337.         $seen = 1 if ref $j and $j eq $_[0];
  2338.       }
  2339.     }
  2340.     die "I'm not in my parent's content list?" unless $seen;
  2341.     return @out;
  2342.   } else {
  2343.     for(my $i = 0; $i < @$pc; ++$i) {
  2344.       return +($i == $#$pc) ? undef : $pc->[$i+1]
  2345.        if ref $pc->[$i] and $pc->[$i] eq $_[0];
  2346.     }
  2347.     die "I'm not in my parent's content list?";
  2348.     return;
  2349.   }
  2350. }
  2351.  
  2352. #--------------------------------------------------------------------------
  2353.  
  2354. =item $h->address()
  2355.  
  2356. Returns a string representing the location of this node in the tree.
  2357. The address consists of numbers joined by a '.', starting with '0',
  2358. and followed by the pindexes of the nodes in the tree that are
  2359. ancestors of $h, starting from the top.
  2360.  
  2361. So if the way to get to a node starting at the root is to go to child
  2362. 2 of the root, then child 10 of that, and then child 0 of that, and
  2363. then you're there -- then that node's address is "0.2.10.0".
  2364.  
  2365. As a bit of a special case, the address of the root is simply "0".
  2366.  
  2367. I forsee this being used mainly for debugging, but you may
  2368. find your own uses for it.
  2369.  
  2370. =item $h->address($address)
  2371.  
  2372. This returns the node (whether element or text-segment) at
  2373. the given address in the tree that $h is a part of.  (That is,
  2374. the address is resolved starting from $h->root.)
  2375.  
  2376. If there is no node at the given address, this returns undef.
  2377.  
  2378. You can specify "relative addressing" (i.e., that indexing is supposed
  2379. to start from $h and not from $h->root) by having the address start
  2380. with a period -- e.g., $h->address(".3.2") will look at child 3 of $h,
  2381. and child 2 of that.
  2382.  
  2383. =cut
  2384.  
  2385. sub address {
  2386.   if(@_ == 1) { # report-address form
  2387.     return
  2388.       join('.',
  2389.         reverse( # so it starts at the top
  2390.           map($_->pindex() || '0', # so that root's undef -> '0'
  2391.             $_[0], # self and...
  2392.             $_[0]->lineage
  2393.           )
  2394.         )
  2395.       )
  2396.     ;
  2397.   } else { # get-node-at-address
  2398.     my @stack = split(/\./, $_[1]);
  2399.     my $here;
  2400.  
  2401.     if(@stack and !length $stack[0]) { # relative addressing
  2402.       $here = $_[0];
  2403.       shift @stack;
  2404.     } else { # absolute addressing
  2405.       return undef unless 0 == shift @stack; # to pop the initial 0-for-root
  2406.       $here = $_[0]->root;
  2407.     }
  2408.  
  2409.     while(@stack) {
  2410.       return undef
  2411.        unless
  2412.          $here->{'_content'}
  2413.          and @{$here->{'_content'}} > $stack[0];
  2414.             # make sure the index isn't too high
  2415.       $here = $here->{'_content'}[ shift @stack ];
  2416.       return undef if @stack and not ref $here;
  2417.         # we hit a text node when we expected a non-terminal element node
  2418.     }
  2419.     
  2420.     return $here;
  2421.   }
  2422. }
  2423.  
  2424.  
  2425. =item $h->depth()
  2426.  
  2427. Returns a number expressing $h's depth within its tree, i.e., how many
  2428. steps away it is from the root.  If $h has no parent (i.e., is root),
  2429. its depth is 0.
  2430.  
  2431. =cut
  2432.  
  2433. #'
  2434. sub depth {
  2435.   my $here = $_[0];
  2436.   my $depth = 0;
  2437.   while(defined($here = $here->{'_parent'}) and ref($here)) {
  2438.     ++$depth;
  2439.   }
  2440.   return $depth;
  2441. }
  2442.  
  2443.  
  2444.  
  2445. =item $h->root()
  2446.  
  2447. Returns the element that's the top of $h's tree.  If $h is root, this
  2448. just returns $h.  (If you want to test whether $h I<is> the root,
  2449. instead of asking what its root is, just test not($h->parent).)
  2450.  
  2451. =cut
  2452.  
  2453. #'
  2454. sub root {
  2455.   my $here = my $root = shift;
  2456.   while(defined($here = $here->{'_parent'}) and ref($here)) {
  2457.     $root = $here;
  2458.   }
  2459.   return $root;
  2460. }
  2461.  
  2462.  
  2463. =item $h->lineage()
  2464.  
  2465. Returns the list of $h's ancestors, starting with its parent, and then
  2466. that parent's parent, and so on, up to the root.  If $h is root, this
  2467. returns an empty list.
  2468.  
  2469. If you simply want a count of the number of elements in $h's lineage,
  2470. use $h->depth.
  2471.  
  2472. =cut
  2473.  
  2474. #'
  2475. sub lineage {
  2476.   my $here = shift;
  2477.   my @lineage;
  2478.   while(defined($here = $here->{'_parent'}) and ref($here)) {
  2479.     push @lineage, $here;
  2480.   }
  2481.   return @lineage;
  2482. }
  2483.  
  2484.  
  2485. =item $h->lineage_tag_names()
  2486.  
  2487. Returns the list of the tag names of $h's ancestors, starting
  2488. with its parent, and that parent's parent, and so on, up to the
  2489. root.  If $h is root, this returns an empty list.
  2490. Example output: C<('em', 'td', 'tr', 'table', 'body', 'html')>
  2491.  
  2492. =cut
  2493.  
  2494. #'
  2495. sub lineage_tag_names {
  2496.   my $here = my $start = shift;
  2497.   my @lineage_names;
  2498.   while(defined($here = $here->{'_parent'}) and ref($here)) {
  2499.     push @lineage_names, $here->{'_tag'};
  2500.   }
  2501.   return @lineage_names;
  2502. }
  2503.  
  2504.  
  2505. =item $h->descendants()
  2506.  
  2507. In list context, returns the list of all $h's descendant elements,
  2508. listed in pre-order (i.e., an element appears before its
  2509. content-elements).  Text segments DO NOT appear in the list.
  2510. In scalar context, returns a count of all such elements.
  2511.  
  2512. =item $h->descendents()
  2513.  
  2514. This is just an alias to the C<descendants> method.
  2515.  
  2516. =cut
  2517.  
  2518. #'
  2519.  
  2520. sub descendents { shift->descendants(@_) }
  2521.  
  2522. sub descendants {
  2523.   my $start = shift;
  2524.   if(wantarray) {
  2525.     my @descendants;
  2526.     $start->traverse(
  2527.       [ # pre-order sub only
  2528.         sub {
  2529.           push(@descendants, $_[0]);
  2530.           return 1;
  2531.         },
  2532.         undef # no post
  2533.       ],
  2534.       1, # ignore text
  2535.     );
  2536.     shift @descendants; # so $self doesn't appear in the list
  2537.     return @descendants;
  2538.   } else { # just returns a scalar
  2539.     my $descendants = -1; # to offset $self being counted
  2540.     $start->traverse(
  2541.       [ # pre-order sub only
  2542.         sub {
  2543.           ++$descendants;
  2544.           return 1;
  2545.         },
  2546.         undef # no post
  2547.       ],
  2548.       1, # ignore text
  2549.     );
  2550.     return $descendants;
  2551.   }
  2552. }
  2553.  
  2554.  
  2555. =item $h->find_by_tag_name('tag', ...)
  2556.  
  2557. In list context, returns a list of elements at or under $h that have
  2558. any of the specified tag names.  In scalar context, returns the first
  2559. (in pre-order traversal of the tree) such element found, or undef if
  2560. none.
  2561.  
  2562. =item $h->find('tag', ...)
  2563.  
  2564. This is just an alias to C<find_by_tag_name>.  (There was once
  2565. going to be a whole find_* family of methods, but then look_down
  2566. filled that niche, so there turned out not to be much reason for the
  2567. verboseness of the name "find_by_tag_name".)
  2568.  
  2569. =cut
  2570.  
  2571. sub find { shift->find_by_tag_name( @_ ) }
  2572.  # yup, a handy alias
  2573.  
  2574.  
  2575. sub find_by_tag_name {
  2576.   my(@pile) = shift(@_); # start out the to-do stack for the traverser
  2577.   Carp::croak "find_by_tag_name can be called only as an object method"
  2578.    unless ref $pile[0];
  2579.   return() unless @_;
  2580.   my(@tags) = $pile[0]->_fold_case(@_);
  2581.   my(@matching, $this, $this_tag);
  2582.   while(@pile) {
  2583.     $this_tag = ($this = shift @pile)->{'_tag'};
  2584.     foreach my $t (@tags) {
  2585.       if($t eq $this_tag) {
  2586.         if(wantarray) {
  2587.           push @matching, $this;
  2588.           last;
  2589.         } else {
  2590.           return $this;
  2591.         }
  2592.       }
  2593.     }
  2594.     unshift @pile, grep ref($_), @{$this->{'_content'} || next};
  2595.   }
  2596.   return @matching if wantarray;
  2597.   return;
  2598. }
  2599.  
  2600. =item $h->find_by_attribute('attribute', 'value')
  2601.  
  2602. In a list context, returns a list of elements at or under $h that have
  2603. the specified attribute, and have the given value for that attribute.
  2604. In a scalar context, returns the first (in pre-order traversal of the
  2605. tree) such element found, or undef if none.
  2606.  
  2607. This method is B<deprecated> in favor of the more expressive
  2608. C<look_down> method, which new code should use instead.
  2609.  
  2610. =cut
  2611.  
  2612.  
  2613. sub find_by_attribute {
  2614.   # We could limit this to non-internal attributes, but hey.
  2615.   my($self, $attribute, $value) = @_;
  2616.   Carp::croak "Attribute must be a defined value!" unless defined $attribute;
  2617.   $attribute =  $self->_fold_case($attribute);
  2618.   
  2619.   my @matching;
  2620.   my $wantarray = wantarray;
  2621.   my $quit;
  2622.   $self->traverse(
  2623.     [ # pre-order only
  2624.       sub {
  2625.         if( exists $_[0]{$attribute}
  2626.              and $_[0]{$attribute} eq $value
  2627.         ) {
  2628.           push @matching, $_[0];
  2629.           return HTML::Element::ABORT unless $wantarray; # only take the first
  2630.         }
  2631.         1; # keep traversing
  2632.       },
  2633.       undef # no post
  2634.     ],
  2635.     1, # yes, ignore text nodes.
  2636.   );
  2637.  
  2638.   if($wantarray) {
  2639.     return @matching;
  2640.   } else {
  2641.     return undef unless @matching;
  2642.     return $matching[0];
  2643.   }
  2644. }
  2645.  
  2646. #--------------------------------------------------------------------------
  2647.  
  2648. =item $h->look_down( ...criteria... )
  2649.  
  2650. This starts at $h and looks thru its element descendants (in
  2651. pre-order), looking for elements matching the criteria you specify.
  2652. In list context, returns all elements that match all the given
  2653. criteria; in scalar context, returns the first such element (or undef,
  2654. if nothing matched).
  2655.  
  2656. There are three kinds of criteria you can specify:
  2657.  
  2658. =over
  2659.  
  2660. =item (attr_name, attr_value)
  2661.  
  2662. This means you're looking for an element with that value for that
  2663. attribute.  Example: C<"alt", "pix!">.  Consider that you can search
  2664. on internal attribute values too: C<"_tag", "p">.
  2665.  
  2666. =item (attr_name, qr/.../)
  2667.  
  2668. This means you're looking for an element whose value for that
  2669. attribute matches the specified Regexp object.
  2670.  
  2671. =item a coderef
  2672.  
  2673. This means you're looking for elements where coderef->(each_element)
  2674. returns true.  Example:
  2675.  
  2676.   my @wide_pix_images
  2677.     = $h->look_down(
  2678.                     "_tag", "img",
  2679.                     "alt", "pix!",
  2680.                     sub { $_[0]->attr('width') > 350 }
  2681.                    );
  2682.  
  2683. =back
  2684.  
  2685. Note that C<(attr_name, attr_value)> and C<(attr_name, qr/.../)>
  2686. criteria are almost always faster than coderef
  2687. criteria, so should presumably be put before them in your list of
  2688. criteria.  That is, in the example above, the sub ref is called only
  2689. for elements that have already passed the criteria of having a "_tag"
  2690. attribute with value "img", and an "alt" attribute with value "pix!".
  2691. If the coderef were first, it would be called on every element, and
  2692. I<then> what elements pass that criterion (i.e., elements for which
  2693. the coderef returned true) would be checked for their "_tag" and "alt"
  2694. attributes.
  2695.  
  2696. Note that comparison of string attribute-values against the string
  2697. value in C<(attr_name, attr_value)> is case-INsensitive!  A criterion
  2698. of C<('align', 'right')> I<will> match an element whose "align" value
  2699. is "RIGHT", or "right" or "rIGhT", etc.
  2700.  
  2701. Note also that C<look_down> considers "" (empty-string) and undef to
  2702. be different things, in attribute values.  So this:
  2703.  
  2704.   $h->look_down("alt", "")
  2705.  
  2706. will find elements I<with> an "alt" attribute, but where the value for
  2707. the "alt" attribute is "".  But this:
  2708.  
  2709.   $h->look_down("alt", undef)
  2710.  
  2711. is the same as:
  2712.  
  2713.   $h->look_down(sub { !defined($_[0]->attr('alt')) } )
  2714.  
  2715. That is, it finds elements that do not have an "alt" attribute at all
  2716. (or that do have an "alt" attribute, but with a value of undef --
  2717. which is not normally possible).
  2718.  
  2719. Note that when you give several criteria, this is taken to mean you're
  2720. looking for elements that match I<all> your criterion, not just I<any>
  2721. of them.  In other words, there is an implicit "and", not an "or".  So
  2722. if you wanted to express that you wanted to find elements with a
  2723. "name" attribute with the value "foo" I<or> with an "id" attribute
  2724. with the value "baz", you'd have to do it like:
  2725.  
  2726.   @them = $h->look_down(
  2727.     sub {
  2728.       # the lcs are to fold case
  2729.       lc($_[0]->attr('name')) eq 'foo'
  2730.       or lc($_[0]->attr('id')) eq 'baz'
  2731.     }
  2732.   );
  2733.  
  2734. Coderef criteria are more expressive than C<(attr_name, attr_value)>
  2735. and C<(attr_name, qr/.../)>
  2736. criteria, and all C<(attr_name, attr_value)>
  2737. and C<(attr_name, qr/.../)>
  2738. criteria could be
  2739. expressed in terms of coderefs.  However, C<(attr_name, attr_value)>
  2740. and C<(attr_name, qr/.../)>
  2741. criteria are a convenient shorthand.  (In fact, C<look_down> itself is
  2742. basically "shorthand" too, since anything you can do with C<look_down>
  2743. you could do by traversing the tree, either with the C<traverse>
  2744. method or with a routine of your own.  However, C<look_down> often
  2745. makes for very concise and clear code.)
  2746.  
  2747. =cut
  2748.  
  2749. sub look_down {
  2750.   ref($_[0]) or Carp::croak "look_down works only as an object method";
  2751.  
  2752.   my @criteria;
  2753.   for(my $i = 1; $i < @_;) {
  2754.     Carp::croak "Can't use undef as an attribute name" unless defined $_[$i];
  2755.     if(ref $_[$i]) {
  2756.       Carp::croak "A " . ref($_[$i]) . " value is not a criterion"
  2757.         unless ref $_[$i] eq 'CODE';
  2758.       push @criteria, $_[ $i++ ];
  2759.     } else {
  2760.       Carp::croak "param list to look_down ends in a key!" if $i == $#_;
  2761.       push @criteria, [ scalar($_[0]->_fold_case($_[$i])), 
  2762.                         defined($_[$i+1])
  2763.                           ? ( ( ref $_[$i+1] ? $_[$i+1] : lc( $_[$i+1] )), ref( $_[$i+1] ) )
  2764.                                                # yes, leave that LC!
  2765.                           : undef
  2766.                       ];
  2767.       $i += 2;
  2768.     }
  2769.   }
  2770.   Carp::croak "No criteria?" unless @criteria;
  2771.  
  2772.   my(@pile) = ($_[0]);
  2773.   my(@matching, $val, $this);
  2774.  Node:
  2775.   while(defined($this = shift @pile)) {
  2776.     # Yet another traverser implemented with merely iterative code.
  2777.     foreach my $c (@criteria) {
  2778.       if(ref($c) eq 'CODE') {
  2779.         next Node unless $c->($this);  # jump to the continue block
  2780.       } else { # it's an attr-value pair
  2781.         next Node  # jump to the continue block
  2782.           if # two values are unequal if:
  2783.             (defined($val = $this->{ $c->[0] }))
  2784.               ? (
  2785.                   !defined $c->[1]  # actual is def, critval is undef => fail
  2786.              # allow regex matching
  2787.             # allow regex matching
  2788.           or (
  2789.           $c->[2] eq 'Regexp'
  2790.             ? $val !~ $c->[1]
  2791.             : ( ref $val ne $c->[2]
  2792.                    # have unequal ref values => fail
  2793.                   or lc($val) ne $c->[1]
  2794.                    # have unequal lc string values => fail
  2795.                   ))
  2796.                 )
  2797.               : (defined $c->[1]) # actual is undef, critval is def => fail
  2798.       }
  2799.     }
  2800.     # We make it this far only if all the criteria passed.
  2801.     return $this unless wantarray;
  2802.     push @matching, $this;
  2803.   } continue {
  2804.     unshift @pile, grep ref($_), @{$this->{'_content'} || $nillio};
  2805.   }
  2806.   return @matching if wantarray;
  2807.   return;
  2808. }
  2809.  
  2810.  
  2811. =item $h->look_up( ...criteria... )
  2812.  
  2813. This is identical to $h->look_down, except that whereas $h->look_down
  2814. basically scans over the list:
  2815.  
  2816.    ($h, $h->descendants)
  2817.  
  2818. $h->look_up instead scans over the list
  2819.  
  2820.    ($h, $h->lineage)
  2821.  
  2822. So, for example, this returns all ancestors of $h (possibly including
  2823. $h itself) that are "td" elements with an "align" attribute with a
  2824. value of "right" (or "RIGHT", etc.):
  2825.  
  2826.    $h->look_up("_tag", "td", "align", "right");
  2827.  
  2828. =cut
  2829.  
  2830. sub look_up {
  2831.   ref($_[0]) or Carp::croak "look_up works only as an object method";
  2832.  
  2833.   my @criteria;
  2834.   for(my $i = 1; $i < @_;) {
  2835.     Carp::croak "Can't use undef as an attribute name" unless defined $_[$i];
  2836.     if(ref $_[$i]) {
  2837.       Carp::croak "A " . ref($_[$i]) . " value is not a criterion"
  2838.         unless ref $_[$i] eq 'CODE';
  2839.       push @criteria, $_[ $i++ ];
  2840.     } else {
  2841.       Carp::croak "param list to look_up ends in a key!" if $i == $#_;
  2842.       push @criteria, [ scalar($_[0]->_fold_case($_[$i])),
  2843.                         defined($_[$i+1])
  2844.                           ? ( ( ref $_[$i+1] ? $_[$i+1] : lc( $_[$i+1] )), ref( $_[$i+1] ) )
  2845.                           : undef  # Yes, leave that LC!
  2846.                       ];
  2847.       $i += 2;
  2848.     }
  2849.   }
  2850.   Carp::croak "No criteria?" unless @criteria;
  2851.  
  2852.   my(@matching, $val);
  2853.   my $this = $_[0];
  2854.  Node:
  2855.   while(1) {
  2856.     # You'll notice that the code here is almost the same as for look_down.
  2857.     foreach my $c (@criteria) {
  2858.       if(ref($c) eq 'CODE') {
  2859.         next Node unless $c->($this);  # jump to the continue block
  2860.       } else { # it's an attr-value pair
  2861.         next Node  # jump to the continue block
  2862.           if # two values are unequal if:
  2863.             (defined($val = $this->{ $c->[0] }))
  2864.               ? (
  2865.                   !defined $c->[1]  # actual is def, critval is undef => fail
  2866.           or (
  2867.           $c->[2] eq 'Regexp'
  2868.             ? $val !~ $c->[1]
  2869.             : ( ref $val ne $c->[2]
  2870.                    # have unequal ref values => fail
  2871.                   or lc($val) ne $c->[1]
  2872.                    # have unequal lc string values => fail
  2873.                   ))
  2874.                 )
  2875.               : (defined $c->[1]) # actual is undef, critval is def => fail
  2876.       }
  2877.     }
  2878.     # We make it this far only if all the criteria passed.
  2879.     return $this unless wantarray;
  2880.     push @matching, $this;
  2881.   } continue {
  2882.     last unless defined($this = $this->{'_parent'}) and ref $this;
  2883.   }
  2884.  
  2885.   return @matching if wantarray;
  2886.   return;
  2887. }
  2888.  
  2889. #--------------------------------------------------------------------------
  2890.  
  2891. =item $h->traverse(...options...)
  2892.  
  2893. Lengthy discussion of HTML::Element's unnecessary and confusing
  2894. C<traverse> method has been moved to a separate file:
  2895. L<HTML::Element::traverse>
  2896.  
  2897. =item $h->attr_get_i('attribute')
  2898.  
  2899. In list context, returns a list consisting of the values of the given
  2900. attribute for $self and for all its ancestors starting from $self and
  2901. working its way up.  Nodes with no such attribute are skipped.
  2902. ("attr_get_i" stands for "attribute get, with inheritance".)
  2903. In scalar context, returns the first such value, or undef if none.
  2904.  
  2905. Consider a document consisting of:
  2906.  
  2907.    <html lang='i-klingon'>
  2908.      <head><title>Pati Pata</title></head>
  2909.      <body>
  2910.        <h1 lang='la'>Stuff</h1>
  2911.        <p lang='es-MX' align='center'>
  2912.          Foo bar baz <cite>Quux</cite>.
  2913.        </p>
  2914.        <p>Hooboy.</p>
  2915.      </body>
  2916.    </html>
  2917.  
  2918. If $h is the "cite" element, $h->attr_get_i("lang") in list context
  2919. will return the list ('es-MX', 'i-klingon').  In scalar context, it
  2920. will return the value 'es-MX'.
  2921.  
  2922. If you call with multiple attribute names...
  2923.  
  2924. =item $h->attr_get_i('a1', 'a2', 'a3')
  2925.  
  2926. ...in list context, this will return a list consisting of
  2927. the values of these attributes which exist in $self and its ancestors.
  2928. In scalar context, this returns the first value (i.e., the value of
  2929. the first existing attribute from the first element that has
  2930. any of the attributes listed).  So, in the above example,
  2931.  
  2932.   $h->attr_get_i('lang', 'align');
  2933.  
  2934. will return:
  2935.  
  2936.    ('es-MX', 'center', 'i-klingon') # in list context
  2937.   or
  2938.    'es-MX' # in scalar context.
  2939.  
  2940. But note that this:
  2941.  
  2942.  $h->attr_get_i('align', 'lang');
  2943.  
  2944. will return:
  2945.  
  2946.    ('center', 'es-MX', 'i-klingon') # in list context
  2947.   or
  2948.    'center' # in scalar context.
  2949.  
  2950. =cut
  2951.  
  2952. sub attr_get_i {
  2953.   if(@_ > 2) {
  2954.     my $self = shift;
  2955.     Carp::croak "No attribute names can be undef!"
  2956.      if grep !defined($_), @_;
  2957.     my @attributes = $self->_fold_case(@_);
  2958.     if(wantarray) {
  2959.       my @out;
  2960.       foreach my $x ($self, $self->lineage) {
  2961.         push @out, map { exists($x->{$_}) ? $x->{$_} : () } @attributes;
  2962.       }
  2963.       return @out;
  2964.     } else {
  2965.       foreach my $x ($self, $self->lineage) {
  2966.         foreach my $attribute (@attributes) {
  2967.           return $x->{$attribute} if exists $x->{$attribute}; # found
  2968.         }
  2969.       }
  2970.       return undef; # never found
  2971.     }
  2972.   } else {
  2973.     # Single-attribute search.  Simpler, most common, so optimize
  2974.     #  for the most common case
  2975.     Carp::croak "Attribute name must be a defined value!" unless defined $_[1];
  2976.     my $self = $_[0];
  2977.     my $attribute =  $self->_fold_case($_[1]);
  2978.     if(wantarray) { # list context
  2979.       return
  2980.         map {
  2981.           exists($_->{$attribute}) ? $_->{$attribute} : ()
  2982.         } $self, $self->lineage;
  2983.       ;
  2984.     } else { # scalar context
  2985.       foreach my $x ($self, $self->lineage) {
  2986.         return $x->{$attribute} if exists $x->{$attribute}; # found
  2987.       }
  2988.       return undef; # never found
  2989.     }
  2990.   }
  2991. }
  2992.  
  2993. #--------------------------------------------------------------------------
  2994.  
  2995. =item $h->tagname_map()
  2996.  
  2997. Scans across C<$h> and all its descendants, and makes a hash (a
  2998. reference to which is returned) where each entry consists of a key
  2999. that's a tag name, and a value that's a reference to a list to all
  3000. elements that have that tag name.  I.e., this method returns:
  3001.  
  3002.    {
  3003.      # Across $h and all descendants...
  3004.      'a'   => [ ...list of all 'a'   elements... ],
  3005.      'em'  => [ ...list of all 'em'  elements... ],
  3006.      'img' => [ ...list of all 'img' elements... ],
  3007.    }
  3008.  
  3009. (There are entries in the hash for only those tagnames that occur
  3010. at/under C<$h> -- so if there's no "img" elements, there'll be no
  3011. "img" entry in the hashr(ref) returned.)
  3012.  
  3013. Example usage:
  3014.  
  3015.     my $map_r = $h->tagname_map();
  3016.     my @heading_tags = sort grep m/^h\d$/s, keys %$map_r;
  3017.     if(@heading_tags) {
  3018.       print "Heading levels used: @heading_tags\n";
  3019.     } else {
  3020.       print "No headings.\n"
  3021.     }
  3022.  
  3023. =cut
  3024.  
  3025. sub tagname_map {
  3026.   my(@pile) = $_[0]; # start out the to-do stack for the traverser
  3027.   Carp::croak "find_by_tag_name can be called only as an object method"
  3028.    unless ref $pile[0];
  3029.   my(%map, $this_tag, $this);
  3030.   while(@pile) {
  3031.     $this_tag = ''
  3032.       unless defined(
  3033.        $this_tag = (
  3034.         $this = shift @pile
  3035.        )->{'_tag'}
  3036.       )
  3037.     ; # dance around the strange case of having an undef tagname.
  3038.     push @{ $map{$this_tag} ||= [] }, $this; # add to map
  3039.     unshift @pile, grep ref($_), @{$this->{'_content'} || next}; # traverse
  3040.   }
  3041.   return \%map;
  3042. }
  3043.  
  3044. #--------------------------------------------------------------------------
  3045.  
  3046. =item $h->extract_links() or $h->extract_links(@wantedTypes)
  3047.  
  3048. Returns links found by traversing the element and all of its children
  3049. and looking for attributes (like "href" in an "a" element, or "src" in
  3050. an "img" element) whose values represent links.  The return value is a
  3051. I<reference> to an array.  Each element of the array is reference to
  3052. an array with I<four> items: the link-value, the element that has the
  3053. attribute with that link-value, and the name of that attribute, and
  3054. the tagname of that element.
  3055. (Example: C<['http://www.suck.com/',> I<$elem_obj> C<, 'href', 'a']>.)
  3056. You may or may not end up using the
  3057. element itself -- for some purposes, you may use only the link value.
  3058.  
  3059. You might specify that you want to extract links from just some kinds
  3060. of elements (instead of the default, which is to extract links from
  3061. I<all> the kinds of elements known to have attributes whose values
  3062. represent links).  For instance, if you want to extract links from
  3063. only "a" and "img" elements, you could code it like this:
  3064.  
  3065.   for (@{  $e->extract_links('a', 'img')  }) {
  3066.       my($link, $element, $attr, $tag) = @$_;
  3067.       print
  3068.         "Hey, there's a $tag that links to "
  3069.         $link, ", in its $attr attribute, at ",
  3070.         $element->address(), ".\n";
  3071.   }
  3072.  
  3073. =cut
  3074.  
  3075.  
  3076. sub extract_links
  3077. {
  3078.     my $start = shift;
  3079.  
  3080.     my %wantType;
  3081.     @wantType{$start->_fold_case(@_)} = (1) x @_; # if there were any
  3082.     my $wantType = scalar(@_);
  3083.  
  3084.     my @links;
  3085.  
  3086.     # TODO: add xml:link?
  3087.  
  3088.     my($link_attrs, $tag, $self, $val); # scratch for each iteration
  3089.     $start->traverse(
  3090.       [
  3091.         sub { # pre-order call only
  3092.           $self = $_[0];
  3093.   
  3094.           $tag = $self->{'_tag'};
  3095.           return 1 if $wantType && !$wantType{$tag};  # if we're selective
  3096.   
  3097.           if(defined(  $link_attrs = $HTML::Element::linkElements{$tag}  )) {
  3098.             # If this is a tag that has any link attributes,
  3099.             #  look over possibly present link attributes,
  3100.             #  saving the value, if found.
  3101.             for (ref($link_attrs) ? @$link_attrs : $link_attrs) {
  3102.               if(defined(  $val = $self->attr($_)  )) {
  3103.                 push(@links, [$val, $self, $_, $tag])
  3104.               }
  3105.             }
  3106.           }
  3107.           1; # return true, so we keep recursing
  3108.         },
  3109.         undef
  3110.       ],
  3111.       1, # ignore text nodes
  3112.     );
  3113.     \@links;
  3114. }
  3115.  
  3116. #--------------------------------------------------------------------------
  3117.  
  3118. =item $h->simplify_pres
  3119.  
  3120. In text bits under PRE elements that are at/under $h, this routine
  3121. nativizes all newlines, and expands all tabs.
  3122.  
  3123. That is, if you read a file with lines delimited by C<\cm\cj>'s, the
  3124. text under PRE areas will have C<\cm\cj>'s instead of C<\n>'s. Calling
  3125. $h->nativize_pre_newlines on such a tree will turn C<\cm\cj>'s into
  3126. C<\n>'s.
  3127.  
  3128. Tabs are expanded to however many spaces it takes to get
  3129. to the next 8th column -- the usual way of expanding them.
  3130.  
  3131. =cut
  3132.  
  3133. sub simplify_pres {
  3134.   my $pre = 0;
  3135.  
  3136.   my $sub;
  3137.   my $line;
  3138.   $sub = sub {
  3139.     ++$pre if $_[0]->{'_tag'} eq 'pre';
  3140.     #print "Under $_[0]{'_tag'} tag...  ($pre)\n";
  3141.     foreach my $it (@{ $_[0]->{'_content'} || return }) {
  3142.       if(ref $it) {
  3143.         $sub->( $it );  # recurse!
  3144.       } elsif($pre) {
  3145.         #$it =~ s/(?:(?:\cm\cj*)|(?:\cj))/\n/g;
  3146.  
  3147.         $it =
  3148.       join "\n",
  3149.         map {;
  3150.           $line = $_;
  3151.           while($line =~
  3152.              s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
  3153.               # Sort of adapted from Text::Tabs -- yes, it's hardwired-in that
  3154.               # tabs are at every EIGHTH column.
  3155.             ){}
  3156.             $line;
  3157.       }
  3158.       split /(?:(?:\cm\cj*)|(?:\cj))/, $it, -1
  3159.     ;
  3160.       }
  3161.     }
  3162.     --$pre if $_[0]->{'_tag'} eq 'pre';
  3163.     return;
  3164.   };
  3165.   $sub->( $_[0] );
  3166.   
  3167.   undef $sub;
  3168.   return;
  3169.  
  3170. }
  3171.  
  3172.  
  3173.  
  3174. #--------------------------------------------------------------------------
  3175.  
  3176. =item $h->same_as($i)
  3177.  
  3178. Returns true if $h and $i are both elements representing the same tree
  3179. of elements, each with the same tag name, with the same explicit
  3180. attributes (i.e., not counting attributes whose names start with "_"),
  3181. and with the same content (textual, comments, etc.).
  3182.  
  3183. Sameness of descendant elements is tested, recursively, with
  3184. C<$child1-E<gt>same_as($child_2)>, and sameness of text segments is tested
  3185. with C<$segment1 eq $segment2>.
  3186.  
  3187. =cut
  3188.  
  3189. sub same_as {
  3190.   die "same_as() takes only one argument: \$h->same_as(\$i)" unless @_ == 2;
  3191.   my($h,$i) = @_[0,1];
  3192.   die "same_as() can be called only as an object method" unless ref $h;
  3193.  
  3194.   return 0 unless defined $i and ref $i;
  3195.    # An element can't be same_as anything but another element!
  3196.    # They needn't be of the same class, tho.
  3197.  
  3198.   return 1 if $h eq $i;
  3199.    # special (if rare) case: anything is the same as... itself!
  3200.   
  3201.   # assumes that no content lists in/under $h or $i contain subsequent
  3202.   #  text segments, like: ['foo', ' bar']
  3203.   
  3204.   # compare attributes now.
  3205.   #print "Comparing tags of $h and $i...\n";
  3206.  
  3207.   return 0 unless $h->{'_tag'} eq $i->{'_tag'};
  3208.     # only significant attribute whose name starts with "_"
  3209.   
  3210.   #print "Comparing attributes of $h and $i...\n";
  3211.   # Compare attributes, but only the real ones.
  3212.   {
  3213.     # Bear in mind that the average element has very few attributes,
  3214.     #  and that element names are rather short.
  3215.     # (Values are a different story.)
  3216.     
  3217.     my @keys_h = sort grep {length $_ and substr($_,0,1) ne '_'} keys %$h;
  3218.     my @keys_i = sort grep {length $_ and substr($_,0,1) ne '_'} keys %$i;
  3219.     
  3220.     #print '<', join(',', @keys_h), '> =?= <', join(',', @keys_i), ">\n";
  3221.     
  3222.     return 0 unless @keys_h == @keys_i;
  3223.      # different number of real attributes?  they're different.
  3224.     for(my $x = 0; $x < @keys_h; ++$x) {
  3225.       return 0 unless
  3226.        $keys_h[$x] eq $keys_i[$x] and  # same key name
  3227.        $h->{$keys_h[$x]} eq $i->{$keys_h[$x]}; # same value
  3228.        # Should this test for definedness on values?
  3229.        # People shouldn't be putting undef in attribute values, I think.
  3230.     }
  3231.   }
  3232.   
  3233.   #print "Comparing children of $h and $i...\n";
  3234.   my $hcl = $h->{'_content'} || [];
  3235.   my $icl = $i->{'_content'} || [];
  3236.   
  3237.   return 0 unless @$hcl == @$icl;
  3238.    # different numbers of children?  they're different.
  3239.   
  3240.   if(@$hcl) {
  3241.     # compare each of the children:
  3242.     for(my $x = 0; $x < @$hcl; ++$x) {
  3243.       if(ref $hcl->[$x]) {
  3244.         return 0 unless ref($icl->[$x]);
  3245.          # an element can't be the same as a text segment
  3246.         # Both elements:
  3247.         return 0 unless $hcl->[$x]->same_as($icl->[$x]);  # RECURSE!
  3248.       } else {
  3249.         return 0 if ref($icl->[$x]);
  3250.          # a text segment can't be the same as an element
  3251.         # Both text segments:
  3252.         return 0 unless $hcl->[$x] eq $icl->[$x];
  3253.       }
  3254.     }
  3255.   }
  3256.   
  3257.   return 1; # passed all the tests!
  3258. }
  3259.  
  3260.  
  3261. #--------------------------------------------------------------------------
  3262.  
  3263. =item $h = HTML::Element->new_from_lol(ARRAYREF)
  3264.  
  3265. Resursively constructs a tree of nodes, based on the (non-cyclic)
  3266. data structure represented by ARRAYREF, where that is a reference
  3267. to an array of arrays (of arrays (of arrays (etc.))).
  3268.  
  3269. In each arrayref in that structure, different kinds of values are
  3270. treated as follows:
  3271.  
  3272. =over
  3273.  
  3274. =item * Arrayrefs
  3275.  
  3276. Arrayrefs are considered to
  3277. designate a sub-tree representing children for the node constructed
  3278. from the current arrayref.
  3279.  
  3280. =item * Hashrefs
  3281.  
  3282. Hashrefs are considered to contain
  3283. attribute-value pairs to add to the element to be constructed from
  3284. the current arrayref
  3285.  
  3286. =item * Text segments
  3287.  
  3288. Text segments at the start of any arrayref
  3289. will be considered to specify the name of the element to be
  3290. constructed from the current araryref; all other text segments will
  3291. be considered to specify text segments as children for the current
  3292. arrayref.
  3293.  
  3294. =item * Elements
  3295.  
  3296. Existing element objects are either inserted into the treelet
  3297. constructed, or clones of them are.  That is, when the lol-tree is
  3298. being traversed and elements constructed based what's in it, if
  3299. an existing element object is found, if it has no parent, then it is
  3300. added directly to the treelet constructed; but if it has a parent,
  3301. then C<$that_node-E<gt>clone> is added to the treelet at the
  3302. appropriate place.
  3303.  
  3304. =back
  3305.  
  3306. An example will hopefully make this more obvious:
  3307.  
  3308.   my $h = HTML::Element->new_from_lol(
  3309.     ['html',
  3310.       ['head',
  3311.         [ 'title', 'I like stuff!' ],
  3312.       ],
  3313.       ['body',
  3314.         {'lang', 'en-JP', _implicit => 1},
  3315.         'stuff',
  3316.         ['p', 'um, p < 4!', {'class' => 'par123'}],
  3317.         ['div', {foo => 'bar'}, '123'],
  3318.       ]
  3319.     ]
  3320.   );
  3321.   $h->dump;
  3322.  
  3323. Will print this:
  3324.  
  3325.   <html> @0
  3326.     <head> @0.0
  3327.       <title> @0.0.0
  3328.         "I like stuff!"
  3329.     <body lang="en-JP"> @0.1 (IMPLICIT)
  3330.       "stuff"
  3331.       <p class="par123"> @0.1.1
  3332.         "um, p < 4!"
  3333.       <div foo="bar"> @0.1.2
  3334.         "123"
  3335.  
  3336. And printing $h->as_HTML will give something like:
  3337.  
  3338.   <html><head><title>I like stuff!</title></head>
  3339.   <body lang="en-JP">stuff<p class="par123">um, p < 4!
  3340.   <div foo="bar">123</div></body></html>
  3341.  
  3342. You can even do fancy things with C<map>:
  3343.  
  3344.   $body->push_content(
  3345.     # push_content implicitly calls new_from_lol on arrayrefs...
  3346.     ['br'],
  3347.     ['blockquote',
  3348.       ['h2', 'Pictures!'],
  3349.       map ['p', $_],
  3350.       $body2->look_down("_tag", "img"),
  3351.         # images, to be copied from that other tree.
  3352.     ],
  3353.     # and more stuff:
  3354.     ['ul',
  3355.       map ['li', ['a', {'href'=>"$_.png"}, $_ ] ],
  3356.       qw(Peaches Apples Pears Mangos)
  3357.     ],
  3358.   );
  3359.  
  3360. =item @elements = HTML::Element->new_from_lol(ARRAYREFS)
  3361.  
  3362. Constructs I<several> elements, by calling
  3363. new_from_lol for every arrayref in the ARRAYREFS list.
  3364.  
  3365.   @elements = HTML::Element->new_from_lol(
  3366.     ['hr'],
  3367.     ['p', 'And there, on the door, was a hook!'],
  3368.   );
  3369.    # constructs two elements.
  3370.  
  3371. =cut
  3372.  
  3373. sub new_from_lol {
  3374.   my $class = shift;
  3375.   $class = ref($class) || $class;
  3376.    # calling as an object method is just the same as ref($h)->new_from_lol(...)
  3377.   my $lol = $_[1];
  3378.  
  3379.   my @ancestor_lols;
  3380.    # So we can make sure there's no cyclicities in this lol.
  3381.    # That would be perverse, but one never knows.
  3382.   my($sub, $k, $v, $node); # last three are scratch values
  3383.   $sub = sub {
  3384.     #print "Building for $_[0]\n";
  3385.     my $lol = $_[0];
  3386.     return unless @$lol;
  3387.     my(@attributes, @children);
  3388.     Carp::croak "Cyclicity detected in source LOL tree, around $lol?!?"
  3389.      if grep($_ eq $lol, @ancestor_lols);
  3390.     push @ancestor_lols, $lol;
  3391.  
  3392.     my $tag_name = 'null';
  3393.  
  3394.     # Recursion in in here:
  3395.     for(my $i = 0; $i < @$lol; ++$i) { # Iterate over children
  3396.       if(ref($lol->[$i]) eq 'ARRAY') { # subtree: most common thing in loltree
  3397.         push @children, $sub->($lol->[$i]);
  3398.       } elsif(! ref($lol->[$i])) {
  3399.         if($i == 0) { # name
  3400.           $tag_name = $lol->[$i];
  3401.           Carp::croak "\"$tag_name\" isn't a good tag name!"
  3402.            if $tag_name =~ m/[<>\/\x00-\x20]/; # minimal sanity, certainly!
  3403.         } else { # text segment child
  3404.           push @children, $lol->[$i];
  3405.         }
  3406.       } elsif(ref($lol->[$i]) eq 'HASH') { # attribute hashref
  3407.         keys %{$lol->[$i]}; # reset the each-counter, just in case
  3408.         while(($k,$v) = each %{$lol->[$i]}) {
  3409.           push @attributes, $class->_fold_case($k), $v
  3410.             if defined $v and $k ne '_name' and $k ne '_content' and
  3411.             $k ne '_parent';
  3412.           # enforce /some/ sanity!
  3413.         }
  3414.       } elsif(UNIVERSAL::isa($lol->[$i], __PACKAGE__)) {
  3415.         if($lol->[$i]->{'_parent'}) { # if claimed
  3416.           #print "About to clone ", $lol->[$i], "\n";
  3417.           push @children, $lol->[$i]->clone();
  3418.         } else {
  3419.           push @children, $lol->[$i]; # if unclaimed...
  3420.           #print "Claiming ", $lol->[$i], "\n";
  3421.           $lol->[$i]->{'_parent'} = 1; # claim it NOW
  3422.            # This WILL be replaced by the correct value once we actually
  3423.            #  construct the parent, just after the end of this loop...
  3424.         }
  3425.       } else {
  3426.         Carp::croak "new_from_lol doesn't handle references of type "
  3427.           . ref($lol->[$i]);
  3428.       }
  3429.     }
  3430.  
  3431.     pop @ancestor_lols;
  3432.     $node = $class->new($tag_name);
  3433.  
  3434.     #print "Children: @children\n";
  3435.  
  3436.     if($class eq __PACKAGE__) {  # Special-case it, for speed:
  3437.       #print "Special cased / [@attributes]\n";
  3438.       
  3439.       %$node = (%$node, @attributes) if @attributes;
  3440.       #print join(' ', $node, ' ' , map("<$_>", %$node), "\n");
  3441.       if(@children) {
  3442.         $node->{'_content'} = \@children;
  3443.         foreach my $c (@children) { $c->{'_parent'} = $node if ref $c }
  3444.       }
  3445.     } else {  # Do it the clean way...
  3446.       #print "Done neatly\n";
  3447.       while(@attributes) { $node->attr(splice @attributes,0,2) }
  3448.       $node->push_content(@children) if @children;
  3449.     }
  3450.  
  3451.     return $node;
  3452.   };
  3453.   # End of sub definition.
  3454.  
  3455.  
  3456.   if(wantarray) {
  3457.     my(@nodes) = map {; (ref($_) eq 'ARRAY') ? $sub->($_) : $_ } @_;
  3458.       # Let text bits pass thru, I guess.  This makes this act more like
  3459.       #  unshift_content et al.  Undocumented.
  3460.     undef $sub;
  3461.       # so it won't be in its own frame, so its refcount can hit 0
  3462.     return @nodes;
  3463.   } else {
  3464.     Carp::croak "new_from_lol in scalar context needs exactly one lol"
  3465.      unless @_ == 1;
  3466.     return $_[0] unless ref($_[0]) eq 'ARRAY';
  3467.      # used to be a fatal error.  still undocumented tho.
  3468.     $node = $sub->($_[0]);
  3469.     undef $sub;
  3470.       # so it won't be in its own frame, so its refcount can hit 0
  3471.     return $node;
  3472.   }
  3473. }
  3474.  
  3475. #--------------------------------------------------------------------------
  3476.  
  3477. =item $h->objectify_text()
  3478.  
  3479. This turns any text nodes under $h from mere text segments (strings)
  3480. into real objects, pseudo-elements with a tag-name of "~text", and the
  3481. actual text content in an attribute called "text".  (For a discussion
  3482. of pseudo-elements, see the "tag" method, far above.)  This method is
  3483. provided because, for some purposes, it is convenient or necessary to
  3484. be able, for a given text node, to ask what element is its parent; and
  3485. clearly this is not possible if a node is just a text string.
  3486.  
  3487. Note that these "~text" objects are not recognized as text nodes by
  3488. methods like as_text.  Presumably you will want to call
  3489. $h->objectify_text, perform whatever task that you needed that for,
  3490. and then call $h->deobjectify_text before calling anything like
  3491. $h->as_text.
  3492.  
  3493. =item $h->deobjectify_text()
  3494.  
  3495. This undoes the effect of $h->objectify_text.  That is, it takes any
  3496. "~text" pseudo-elements in the tree at/under $h, and deletes each one,
  3497. replacing each with the content of its "text" attribute.
  3498.  
  3499. Note that if $h itself is a "~text" pseudo-element, it will be
  3500. destroyed -- a condition you may need to treat specially in your
  3501. calling code (since it means you can't very well do anything with $h
  3502. after that).  So that you can detect that condition, if $h is itself a
  3503. "~text" pseudo-element, then this method returns the value of the
  3504. "text" attribute, which should be a defined value; in all other cases,
  3505. it returns undef.
  3506.  
  3507. (This method assumes that no "~text" pseudo-element has any children.)
  3508.  
  3509. =cut
  3510.  
  3511. sub objectify_text {
  3512.   my(@stack) = ($_[0]);
  3513.  
  3514.   my($this);
  3515.   while(@stack) {
  3516.     foreach my $c (@{( $this = shift @stack )->{'_content'}}) {
  3517.       if(ref($c)) {
  3518.         unshift @stack, $c;  # visit it later.
  3519.       } else {
  3520.         $c = ( $this->{'_element_class'} || __PACKAGE__
  3521.              )->new('~text', 'text' => $c, '_parent' => $this);
  3522.       }
  3523.     }
  3524.   }
  3525.   return;
  3526. }
  3527.  
  3528. sub deobjectify_text {
  3529.   my(@stack) = ($_[0]);
  3530.   my($old_node);
  3531.  
  3532.   if( $_[0]{'_tag'} eq '~text') { # special case
  3533.     # Puts the $old_node variable to a different purpose
  3534.     if($_[0]{'_parent'}) {
  3535.       $_[0]->replace_with( $old_node = delete $_[0]{'text'} )->delete;
  3536.     } else {  # well, that's that, then!
  3537.       $old_node = delete $_[0]{'text'};
  3538.     }
  3539.  
  3540.     if(ref($_[0]) eq __PACKAGE__) { # common case
  3541.       %{$_[0]} = ();  # poof!
  3542.     } else {
  3543.       # play nice:
  3544.       delete $_[0]{'_parent'};
  3545.       $_[0]->delete;
  3546.     }
  3547.     return '' unless defined $old_node; # sanity!
  3548.     return $old_node;
  3549.   }
  3550.  
  3551.   while(@stack) {
  3552.     foreach my $c (@{(shift @stack)->{'_content'}}) {
  3553.       if(ref($c)) {
  3554.         if($c->{'_tag'} eq '~text') {
  3555.           $c = ($old_node = $c)->{'text'};
  3556.       if(ref($old_node) eq __PACKAGE__) { # common case
  3557.             %$old_node = ();  # poof!
  3558.           } else {
  3559.             # play nice:
  3560.             delete $old_node->{'_parent'};
  3561.             $old_node->delete;
  3562.           }
  3563.         } else {
  3564.           unshift @stack, $c;  # visit it later.
  3565.         }
  3566.       }
  3567.     }
  3568.   }
  3569.  
  3570.   return undef;
  3571. }
  3572.  
  3573. #--------------------------------------------------------------------------
  3574.  
  3575. =item $h->number_lists()
  3576.  
  3577. For every UL, OL, DIR, and MENU element at/under $h, this sets a
  3578. "_bullet" attribute for every child LI element.  For LI children of an
  3579. OL, the "_bullet" attribute's value will be something like "4.", "d.",
  3580. "D.", "IV.", or "iv.", depending on the OL element's "type" attribute.
  3581. LI children of a UL, DIR, or MENU get their "_bullet" attribute set
  3582. to "*".
  3583. There should be no other LIs (i.e., except as children of OL, UL, DIR,
  3584. or MENU elements), and if there are, they are unaffected.
  3585.  
  3586. =cut
  3587.  
  3588. {
  3589.   # The next three subs are basically copied from my module Number::Latin,
  3590.   #  based on a one-liner by Abigail.  Yes, I could simply require that
  3591.   #  module, and a roman numeral module too, but really, HTML-Tree already
  3592.   #  has enough dependecies as it is; and anyhow, I don't need the functions
  3593.   #  that do latin2int or roman2int.
  3594.   no integer;
  3595.  
  3596.   sub _int2latin {
  3597.     return undef unless defined $_[0];
  3598.     return '0' if $_[0] < 1 and $_[0] > -1;
  3599.     return '-' . _i2l( abs int $_[0] ) if $_[0] <= -1; # tolerate negatives
  3600.     return       _i2l(     int $_[0] );
  3601.   }
  3602.  
  3603.   sub _int2LATIN {
  3604.     # just the above plus uc
  3605.     return undef unless defined $_[0];
  3606.     return '0' if $_[0] < 1 and $_[0] > -1;
  3607.     return '-' . uc(_i2l( abs int $_[0] )) if $_[0] <= -1;  # tolerate negs
  3608.     return       uc(_i2l(     int $_[0] ));
  3609.   }
  3610.  
  3611.   my @alpha = ('a' .. 'z'); 
  3612.   sub _i2l { # the real work
  3613.     my $int = $_[0] || return "";
  3614.     _i2l(int (($int - 1) / 26)) . $alpha[$int % 26 - 1];  # yes, recursive
  3615.     # Yes, 26 => is (26 % 26 - 1), which is -1 => Z!
  3616.   }
  3617. }
  3618.  
  3619. {
  3620.   # And now, some much less impressive Roman numerals code:
  3621.  
  3622.   my(@i) = ('', qw(I II III IV V VI VII VIII IX));
  3623.   my(@x) = ('', qw(X XX XXX XL L LX LXX LXXX XC));
  3624.   my(@c) = ('', qw(C CC CCC CD D DC DCC DCCC CM));
  3625.   my(@m) = ('', qw(M MM MMM));
  3626.  
  3627.   sub _int2ROMAN {
  3628.     my($i, $pref);
  3629.     return '0' if 0 == ($i = int($_[0] || 0)); # zero is a special case
  3630.     return $i + 0 if $i <= -4000 or $i >= 4000;
  3631.     # Because over 3999 would require non-ASCII chars, like D-with-)-inside
  3632.     if($i < 0) { # grumble grumble tolerate negatives grumble
  3633.       $pref = '-'; $i = abs($i);
  3634.     } else {
  3635.       $pref = '';  # normal case
  3636.     }
  3637.  
  3638.     my($x,$c,$m) = (0,0,0);
  3639.     if(     $i >= 10) { $x = $i / 10; $i %= 10;
  3640.       if(   $x >= 10) { $c = $x / 10; $x %= 10;
  3641.         if( $c >= 10) { $m = $c / 10; $c %= 10; } } }
  3642.     #print "m$m c$c x$x i$i\n";
  3643.  
  3644.     return join('', $pref, $m[$m], $c[$c], $x[$x], $i[$i] );
  3645.   }
  3646.  
  3647.   sub _int2roman { lc(_int2ROMAN($_[0])) }
  3648. }
  3649.  
  3650. sub _int2int { $_[0] } # dummy
  3651.  
  3652. %list_type_to_sub = (
  3653.   'I' => \&_int2ROMAN,  'i' => \&_int2roman,
  3654.   'A' => \&_int2LATIN,  'a' => \&_int2latin,
  3655.   '1' => \&_int2int,
  3656. );
  3657.  
  3658. sub number_lists {
  3659.   my(@stack) = ($_[0]);
  3660.   my($this, $tag, $counter, $numberer); # scratch
  3661.   while(@stack) { # yup, pre-order-traverser idiom
  3662.     if(($tag = ($this = shift @stack)->{'_tag'}) eq 'ol') {
  3663.       # Prep some things:
  3664.       $counter = (($this->{'start'} || '') =~ m<^\s*(\d{1,7})\s*$>s) ? $1 : 1;
  3665.       $numberer = $list_type_to_sub{ $this->{'type'} || ''}
  3666.                || $list_type_to_sub{'1'};
  3667.  
  3668.       # Immeditately iterate over all children
  3669.       foreach my $c (@{ $this->{'_content'} || next}) {
  3670.     next unless ref $c;
  3671.     unshift @stack, $c;
  3672.     if($c->{'_tag'} eq 'li') {
  3673.       $counter = $1 if(($c->{'value'} || '') =~ m<^\s*(\d{1,7})\s*$>s);
  3674.       $c->{'_bullet'} = $numberer->($counter) . '.';
  3675.       ++$counter;
  3676.     }
  3677.       }
  3678.  
  3679.     } elsif($tag eq 'ul' or $tag eq 'dir' or $tag eq 'menu') {
  3680.       # Immeditately iterate over all children
  3681.       foreach my $c (@{ $this->{'_content'} || next}) {
  3682.     next unless ref $c;
  3683.     unshift @stack, $c;
  3684.     $c->{'_bullet'} = '*' if $c->{'_tag'} eq 'li';
  3685.       }
  3686.  
  3687.     } else {
  3688.       foreach my $c (@{ $this->{'_content'} || next}) {
  3689.     unshift @stack, $c if ref $c;
  3690.       }
  3691.     }
  3692.   }
  3693.   return;
  3694. }
  3695.  
  3696.  
  3697. #--------------------------------------------------------------------------
  3698.  
  3699. =item $h->has_insane_linkage
  3700.  
  3701. This method is for testing whether this element or the elements
  3702. under it have linkage attributes (_parent and _content) whose values
  3703. are deeply aberrant: if there are undefs in a content list; if an
  3704. element appears in the content lists of more than one element;
  3705. if the _parent attribute of an element doesn't match its actual
  3706. parent; or if an element appears as its own descendant (i.e.,
  3707. if there is a cyclicity in the tree).
  3708.  
  3709. This returns empty list (or false, in scalar context) if the subtree's
  3710. linkage methods are sane; otherwise it returns two items (or true, in
  3711. scalar context): the element where the error occurred, and a string
  3712. describing the error.
  3713.  
  3714. This method is provided is mainly for debugging and troubleshooting --
  3715. it should be I<quite impossible> for any document constructed via
  3716. HTML::TreeBuilder to parse into a non-sane tree (since it's not
  3717. the content of the tree per se that's in question, but whether
  3718. the tree in memory was properly constructed); and it I<should> be
  3719. impossible for you to produce an insane tree just thru reasonable
  3720. use of normal documented structure-modifying methods.  But if you're
  3721. constructing your own trees, and your program is going into infinite
  3722. loops as during calls to traverse() or any of the secondary
  3723. structural methods, as part of debugging, consider calling is_insane
  3724. on the tree.
  3725.  
  3726. =cut
  3727.  
  3728. sub has_insane_linkage {
  3729.   my @pile = ($_[0]);
  3730.   my($c, $i, $p, $this); # scratch
  3731.   
  3732.   # Another iterative traverser; this time much simpler because
  3733.   #  only in pre-order:
  3734.   my %parent_of = ($_[0], 'TOP-OF-SCAN');
  3735.   while(@pile) {
  3736.     $this = shift @pile;
  3737.     $c = $this->{'_content'} || next;
  3738.     return($this, "_content attribute is true but nonref.")
  3739.      unless ref($c) eq 'ARRAY';
  3740.     next unless @$c;
  3741.     for($i = 0; $i < @$c; ++$i) {
  3742.       return($this, "Child $i is undef")
  3743.        unless defined $c->[$i];
  3744.       if(ref($c->[$i])) {
  3745.         return($c->[$i], "appears in its own content list")
  3746.          if $c->[$i] eq $this;
  3747.         return($c->[$i],
  3748.           "appears twice in the tree: once under $this, once under $parent_of{$c->[$i]}"
  3749.         )
  3750.          if exists $parent_of{$c->[$i]};
  3751.         $parent_of{$c->[$i]} = ''.$this;
  3752.           # might as well just use the stringification of it.
  3753.         
  3754.         return($c->[$i], "_parent attribute is wrong (not defined)")
  3755.          unless defined($p = $c->[$i]{'_parent'});
  3756.         return($c->[$i], "_parent attribute is wrong (nonref)")
  3757.          unless ref($p);
  3758.         return($c->[$i],
  3759.           "_parent attribute is wrong (is $p; should be $this)"
  3760.         )
  3761.          unless $p eq $this;
  3762.       }
  3763.     }
  3764.     unshift @pile, grep ref($_), @$c;
  3765.      # queue up more things on the pile stack
  3766.   }
  3767.   return; #okay
  3768. }
  3769.  
  3770. #==========================================================================
  3771.  
  3772. sub _asserts_fail {  # to be run on trusted documents only
  3773.   my(@pile) = ($_[0]);
  3774.   my(@errors, $this, $id, $assert, $parent, $rv);
  3775.   while(@pile) {
  3776.     $this = shift @pile;
  3777.     if(defined($assert = $this->{'assert'})) {
  3778.       $id = ($this->{'id'} ||= $this->address); # don't use '0' as an ID, okay?
  3779.       unless(ref($assert)) {
  3780.         package main;
  3781.         $assert = $this->{'assert'} = (
  3782.           $assert =~ m/\bsub\b/ ? eval($assert) : eval("sub {  $assert\n}")
  3783.         );
  3784.         if($@) {
  3785.           push @errors, [$this, "assertion at $id broke in eval: $@"];
  3786.           $assert = $this->{'assert'} = sub {};
  3787.         }
  3788.       }
  3789.       $parent = $this->{'_parent'};
  3790.       $rv = undef;
  3791.       eval {
  3792.         $rv =
  3793.          $assert->(
  3794.            $this, $this->{'_tag'}, $this->{'_id'}, # 0,1,2
  3795.            $parent ? ($parent, $parent->{'_tag'}, $parent->{'id'}) : () # 3,4,5
  3796.          )
  3797.       };
  3798.       if($@) {
  3799.         push @errors, [$this, "assertion at $id died: $@"];
  3800.       } elsif(!$rv) {
  3801.         push @errors, [$this, "assertion at $id failed"]
  3802.       }
  3803.        # else OK
  3804.     }
  3805.     push @pile, grep ref($_), @{$this->{'_content'} || next};
  3806.   }
  3807.   return @errors;
  3808. }
  3809.  
  3810.  
  3811. #==========================================================================
  3812. 1;
  3813.  
  3814. __END__
  3815.  
  3816. =back
  3817.  
  3818. =head1 BUGS
  3819.  
  3820. * If you want to free the memory associated with a tree built of
  3821. HTML::Element nodes, then you will have to delete it explicitly.
  3822. See the $h->delete method, above.
  3823.  
  3824. * There's almost nothing to stop you from making a "tree" with
  3825. cyclicities (loops) in it, which could, for example, make the
  3826. traverse method go into an infinite loop.  So don't make
  3827. cyclicities!  (If all you're doing is parsing HTML files,
  3828. and looking at the resulting trees, this will never be a problem
  3829. for you.)
  3830.  
  3831. * There's no way to represent comments or processing directives
  3832. in a tree with HTML::Elements.  Not yet, at least.
  3833.  
  3834. * There's (currently) nothing to stop you from using an undefined
  3835. value as a text segment.  If you're running under C<perl -w>, however,
  3836. this may make HTML::Element's code produce a slew of warnings.
  3837.  
  3838. =head1 NOTES ON SUBCLASSING
  3839.  
  3840. You are welcome to derive subclasses from HTML::Element, but you
  3841. should be aware that the code in HTML::Element makes certain
  3842. assumptions about elements (and I'm using "element" to mean ONLY an
  3843. object of class HTML::Element, or of a subclass of HTML::Element):
  3844.  
  3845. * The value of an element's _parent attribute must either be undef or
  3846. otherwise false, or must be an element.
  3847.  
  3848. * The value of an element's _content attribute must either be undef or
  3849. otherwise false, or a reference to an (unblessed) array.  The array
  3850. may be empty; but if it has items, they must ALL be either mere
  3851. strings (text segments), or elements.
  3852.  
  3853. * The value of an element's _tag attribute should, at least, be a
  3854. string of printable characters.
  3855.  
  3856. Moreover, bear these rules in mind:
  3857.  
  3858. * Do not break encapsulation on objects.  That is, access their
  3859. contents only thru $obj->attr or more specific methods.
  3860.  
  3861. * You should think twice before completely overriding any of the
  3862. methods that HTML::Element provides.  (Overriding with a method that
  3863. calls the superclass method is not so bad, tho.)
  3864.  
  3865. =head1 SEE ALSO
  3866.  
  3867. L<HTML::Tree>; L<HTML::TreeBuilder>; L<HTML::AsSubs>; L<HTML::Tagset>;
  3868. and, for the morbidly curious, L<HTML::Element::traverse>.
  3869.  
  3870. =head1 COPYRIGHT
  3871.  
  3872. Copyright 1995-1998 Gisle Aas, 1999-2001 Sean M. Burke.
  3873.  
  3874. This library is free software; you can redistribute it and/or
  3875. modify it under the same terms as Perl itself.
  3876.  
  3877. This program is distributed in the hope that it will be useful, but
  3878. without any warranty; without even the implied warranty of
  3879. merchantability or fitness for a particular purpose.
  3880.  
  3881. =head1 AUTHOR
  3882.  
  3883. Original author Gisle Aas E<lt>gisle@aas.noE<gt>; current maintainer
  3884. Sean M. Burke, E<lt>sburke@cpan.orgE<gt>
  3885.  
  3886. =cut
  3887.  
  3888. If you've read the code this far, you need some hummus:
  3889.  
  3890. EASY HUMMUS
  3891. (Adapted from a recipe by Ralph Baccash (1937-2000))
  3892.  
  3893. INGREDIENTS:
  3894.  
  3895.   - The juice of two smallish lemons
  3896.      (adjust to taste, and depending on how juicy the lemons are)
  3897.   - 6 tablespoons of tahini
  3898.   - 4 tablespoons of olive oil
  3899.   - 5 big cloves of garlic, chopped fine
  3900.   - salt to taste
  3901.   - pepper to taste
  3902.   - onion powder to taste
  3903.   - pinch of coriander powder  (optional)
  3904.   - big pinch of cumin
  3905. Then:
  3906.   - 2 16oz cans of garbanzo beans
  3907.   - parsley, or Italian parsley
  3908.   - a bit more olive oil
  3909.  
  3910. PREPARATION:
  3911.  
  3912. Drain one of the cans of garbanzos, discarding the juice.  Drain the
  3913. other, reserving the juice.
  3914.  
  3915. Peel the garbanzos (just pressing on each a bit until the skin slides
  3916. off).  It will take time to peel all the garbanzos.  It's optional, but
  3917. it makes for a smoother hummus.  Incidentally, peeling seems much
  3918. faster and easier if done underwater -- i.e., if the beans are in a
  3919. bowl under an inch or so of water.
  3920.  
  3921. Now, in a blender, combine everything in the above list, starting at the
  3922. top, stopping at (but including) the cumin.  Add one-third of the can's
  3923. worth of the juice that you reserved.  Blend very well.  (For lack of a
  3924. blender, I've done okay using a Braun hand-mixer.)
  3925.  
  3926. Start adding the beans little by little, and keep blending, and
  3927. increasing speeds until very smooth.  If you want to make the mix less
  3928. viscous, add more of the reserved juice.  Adjust the seasoning as
  3929. needed.
  3930.  
  3931. Cover with chopped parsley, and a thin layer of olive oil.  The parsley
  3932. is more or less optional, but the olive oil is necessary, to keep the
  3933. hummus from discoloring.  Possibly sprinkle with paprika or red chile
  3934. flakes.
  3935.  
  3936. Serve at about room temperature, with warm pitas.  Possible garnishes
  3937. include olives, peperoncini, tomato wedges.
  3938.  
  3939. Variations on this recipe consist of adding or substituting other
  3940. spices.  The garbanzos, tahini, lemon juice, and oil are the only really
  3941. core ingredients, and note that their quantities are approximate.
  3942.  
  3943. For more good recipes along these lines, see:
  3944.   Karaoglan, Aida.  1992.  /Food for the Vegetarian/.  Interlink Books,
  3945.   New York.  ISBN 1-56656-105-1.
  3946.   http://www.amazon.com/exec/obidos/ASIN/1566561051/
  3947.  
  3948. # End
  3949.