home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / HTML / Parser.pm < prev    next >
Text File  |  1997-04-07  |  10KB  |  371 lines
  1. package HTML::Parser;
  2.  
  3. # $Id: Parser.pm,v 2.6 1997/02/21 09:32:14 aas Exp $
  4.  
  5. =head1 NAME
  6.  
  7. HTML::Parser - SGML parser class
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.  require HTML::Parser;
  12.  $p = HTML::Parser->new;  # should really a be subclass
  13.  $p->parse($chunk1);
  14.  $p->parse($chunk2);
  15.  #...
  16.  $p->eof;                 # signal end of document
  17.  
  18.  # Parse directly from file
  19.  $p->parse_file("foo.html");
  20.  # or
  21.  open(F, "foo.html") || die;
  22.  $p->parse_file(\*F);
  23.  
  24. =head1 DESCRIPTION
  25.  
  26. The C<HTML::Parser> will tokenize a HTML document when the $p->parse()
  27. method is called.  The document to parse can be supplied in arbitrary
  28. chunks.  Call $p->eof() the end of the document to flush any remaining
  29. text.  The return value from parse() is a reference to the parser
  30. object.
  31.  
  32. The $p->parse_file() method can be called to parse text from a file.
  33. The argument can be a filename or an already opened file handle. The
  34. return value from parse_file() is a reference to the parser object.
  35.  
  36. In order to make the parser do anything interesting, you must make a
  37. subclass where you override one or more of the following methods as
  38. appropriate:
  39.  
  40. =over 4
  41.  
  42. =item $self->declaration($decl)
  43.  
  44. This method is called when a I<markup declaration> has been
  45. recognized.  For typical HTML documents, the only declaration you are
  46. likely to find is <!DOCTYPE ...>.  The initial "<!" and ending ">" is
  47. not part of the string passed as argument.  Comments are removed and
  48. entities have B<not> been expanded yet.
  49.  
  50. =item $self->start($tag, $attr, $attrseq, $origtext)
  51.  
  52. This method is called when a complete start tag has been recognized.
  53. The first argument is the tag name (in lower case) and the second
  54. argument is a reference to a hash that contain all attributes found
  55. within the start tag.  The attribute keys are converted to lower case.
  56. Entities found in the attribute values are already expanded.  The
  57. third argument is a reference to an array with the lower case
  58. attribute keys in the original order.  The fourth argument is the
  59. original HTML text.
  60.  
  61.  
  62. =item $self->end($tag)
  63.  
  64. This method is called when an end tag has been recognized.  The
  65. argument is the lower case tag name.
  66.  
  67. =item $self->text($text)
  68.  
  69. This method is called when plain text in the document is recognized.
  70. The text is passed on unmodified and might contain multiple lines.
  71. Note that for efficiency reasons entities in the text are B<not>
  72. expanded.  You should call HTML::Entities::decode($text) before you
  73. process the text any further.
  74.  
  75. =item $self->comment($comment)
  76.  
  77. This method is called as comments are recognized.  The leading and
  78. trailing "--" sequences have been stripped off the comment text.
  79.  
  80. =back
  81.  
  82. The default implementation of these methods does nothing, I<i.e.,> the
  83. tokens are just ignored.
  84.  
  85. There is really nothing in the basic parser that is HTML specific, so
  86. it is likely that the parser can parse many kinds of SGML documents,
  87. but SGML has many obscure features (not implemented by this module)
  88. that prevent us from renaming this module as C<SGML::Parse>.
  89.  
  90. =head1 BUGS
  91.  
  92. You can instruct the parser to parse comments the way Netscape does it
  93. by calling the netscape_buggy_comment() method with a TRUE argument.
  94. This means that comments will always be terminated by the first
  95. occurence of "-->".
  96.  
  97. =head1 SEE ALSO
  98.  
  99. L<HTML::TreeBuilder>, L<HTML::HeadParser>, L<HTML::Entities>
  100.  
  101. =head1 COPYRIGHT
  102.  
  103. Copyright 1996 Gisle Aas. All rights reserved.
  104.  
  105. This library is free software; you can redistribute it and/or
  106. modify it under the same terms as Perl itself.
  107.  
  108. =head1 AUTHOR
  109.  
  110. Gisle Aas <aas@sn.no>
  111.  
  112. =cut
  113.  
  114.  
  115. use strict;
  116.  
  117. use HTML::Entities ();
  118. use vars qw($VERSION);
  119. $VERSION = sprintf("%d.%02d", q$Revision: 2.6 $ =~ /(\d+)\.(\d+)/);
  120.  
  121.  
  122. sub new
  123. {
  124.     my $class = shift;
  125.     my $self = bless { '_buf'              => '',
  126.                '_netscape_comment' => 0,
  127.              }, $class;
  128.     $self;
  129. }
  130.  
  131. # How does Netscape do it: It parse <xmp> in the depreceated 'literal'
  132. # mode, i.e. no tags are recognized until a </xmp> is found.
  133. # 
  134. # <listing> is parsed like <pre>, i.e. tags are recognized.  <listing>
  135. # are presentend in smaller font than <pre>
  136. #
  137. # Netscape does not parse this comment correctly (it terminates the comment
  138. # too early):
  139. #
  140. #    <! -- comment -- --> more comment -->
  141. #
  142. # Netscape does not allow space after the initial "<" in the start tag.
  143. # Like this "<a href='gisle'>"
  144. #
  145. # Netscape ignore '<!--' and '-->' within the <SCRIPT> tag.  This is used
  146. # as a trick to make non-script-aware browsers ignore the scripts.
  147.  
  148.  
  149. sub eof
  150. {
  151.     shift->parse(undef);
  152. }
  153.  
  154.  
  155. sub parse
  156. {
  157.     my $self = shift;
  158.     my $buf = \ $self->{'_buf'};
  159.     unless (defined $_[0]) {
  160.     # signals EOF (assume rest is plain text)
  161.     $self->text($$buf) if length $$buf;
  162.     $$buf = '';
  163.     return $self;
  164.     }
  165.     $$buf .= $_[0];
  166.  
  167.     # Parse html text in $$buf.  The strategy is to remove complete
  168.     # tokens from the beginning of $$buf until we can't deside whether
  169.     # it is a token or not, or the $$buf is empty.
  170.     while (1) {  # the loop will end by returning when text is parsed
  171.     # First we try to pull off any plain text (anything before a "<" char)
  172.     if ($$buf =~ s|^([^<]+)||) {
  173.         unless (length $$buf) {
  174.         my $text = $1;
  175.         # At the end of the buffer, we should not parse white space
  176.         # but leave it for parsing on the next round.
  177.         if ($text =~ s|(\s+)$||) {
  178.             $$buf = $1;
  179.                 # Same treatment for chopped up entites.
  180.         } elsif ($text =~ s/(&(?:(?:\#\d*)?|\w*))$//) {
  181.             $$buf = $1;
  182.         };
  183.         $self->text($text);
  184.         return $self;
  185.         } else {
  186.         $self->text($1);
  187.         }
  188.     # Netscapes buggy comments are easy to handle
  189.     } elsif ($self->{'_netscape_comment'} && $$buf =~ m|^(<!--)|) {
  190.         if ($$buf =~ s|^<!--(.*?)-->||s) {
  191.         $self->comment($1);
  192.         } else {
  193.         return $self;  # must wait until we see the end of it
  194.         }
  195.     # Then, markup declarations (usually either <!DOCTYPE...> or a comment)
  196.     } elsif ($$buf =~ s|^(<!)||) {
  197.         my $eaten = $1;
  198.         my $text = '';
  199.         my @com = ();  # keeps comments until we have seen the end
  200.         # Eat text and beginning of comment
  201.         while ($$buf =~ s|^(([^>]*?)--)||) {
  202.         $eaten .= $1;
  203.         $text .= $2;
  204.         # Look for end of comment
  205.         if ($$buf =~ s|^((.*?)--)||s) {
  206.             $eaten .= $1;
  207.             push(@com, $2);
  208.         } else {
  209.             # Need more data to get all comment text.
  210.             $$buf = $eaten . $$buf;
  211.             return $self;
  212.         }
  213.         }
  214.         # Can we finish the tag
  215.         if ($$buf =~ s|^([^>]*)>||) {
  216.         $text .= $1;
  217.         $self->declaration($text) if $text =~ /\S/;
  218.         # then tell about all the comments we found
  219.         for (@com) { $self->comment($_); }
  220.         } else {
  221.         $$buf = $eaten . $$buf;  # must start with it all next time
  222.         return $self;
  223.         }
  224.         # Should we look for 'processing instructions' <? ...> ??
  225.     #} elsif ($$buf =~ s|<\?||) {
  226.         # ...
  227.     # Then, look for a end tag
  228.     } elsif ($$buf =~ s|^</||) {
  229.         # end tag
  230.         if ($$buf =~ s|^([a-zA-Z][a-zA-Z0-9\.\-]*)\s*>||) {
  231.         $self->end(lc($1));
  232.         } elsif ($$buf =~ m|^[a-zA-Z]*[a-zA-Z0-9\.\-]*\s*$|) {
  233.         $$buf = "</" . $$buf;  # need more data to be sure
  234.         return $self;
  235.         } else {
  236.         # it is plain text after all
  237.         $self->text("</");
  238.         }
  239.     # Then, finally we look for a start tag
  240.     } elsif ($$buf =~ s|^<||) {
  241.         # start tag
  242.         my $eaten = '<';
  243.  
  244.         # This first thing we must find is a tag name.  RFC1866 says:
  245.         #   A name consists of a letter followed by letters,
  246.         #   digits, periods, or hyphens. The length of a name is
  247.         #   limited to 72 characters by the `NAMELEN' parameter in
  248.         #   the SGML declaration for HTML, 9.5, "SGML Declaration
  249.         #   for HTML".  In a start-tag, the element name must
  250.         #   immediately follow the tag open delimiter `<'.
  251.         if ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\.\-]*)\s*)||) {
  252.         $eaten .= $1;
  253.         my $tag = lc $2;
  254.         my %attr;
  255.         my @attrseq;
  256.  
  257.         # Then we would like to find some attributes
  258.                 #
  259.                 # Arrgh!! Since stupid Netscape violates RCF1866 by
  260.                 # using "_" in attribute names (like "ADD_DATE") of
  261.                 # their bookmarks.html, we allow this too.
  262.         while ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\.\-_]*)\s*)||) {
  263.             $eaten .= $1;
  264.             my $attr = lc $2;
  265.             my $val;
  266.             # The attribute might take an optional value (first we
  267.             # check for an unquoted value)
  268.             if ($$buf =~ s|(^=\s*([^\"\'>\s][^>\s]*)\s*)||) {
  269.             $eaten .= $1;
  270.             $val = $2;
  271.             HTML::Entities::decode($val);
  272.             # or quoted by " or '
  273.             } elsif ($$buf =~ s|(^=\s*([\"\'])(.*?)\2\s*)||s) {
  274.             $eaten .= $1;
  275.             $val = $3;
  276.             HTML::Entities::decode($val);
  277.                     # truncated just after the '=' or inside the attribute
  278.             } elsif ($$buf =~ m|^(=\s*)$| or
  279.                  $$buf =~ m|^(=\s*[\"\'].*)|s) {
  280.             $$buf = "$eaten$1";
  281.             return $self;
  282.             } else {
  283.             # assume attribute with implicit value
  284.             $val = $attr;
  285.             }
  286.             $attr{$attr} = $val;
  287.             push(@attrseq, $attr);
  288.         }
  289.  
  290.         # At the end there should be a closing ">"
  291.         if ($$buf =~ s|^>||) {
  292.             $self->start($tag, \%attr, \@attrseq, "$eaten>");
  293.         } elsif (length $$buf) {
  294.             # Not a conforming start tag, regard it as normal text
  295.             $self->text($eaten);
  296.         } else {
  297.             $$buf = $eaten;  # need more data to know
  298.             return $self;
  299.         }
  300.  
  301.         } elsif (length $$buf) {
  302.         $self->text($eaten);
  303.         } else {
  304.         $$buf = $eaten . $$buf;  # need more data to parse
  305.         return $self;
  306.         }
  307.  
  308.     } elsif (length $$buf) {
  309.         die; # This should never happen
  310.     } else {
  311.         # The buffer is empty now
  312.         return $self;
  313.     }
  314.     }
  315.     $self;
  316. }
  317.  
  318. sub netscape_buggy_comment
  319. {
  320.     my $self = shift;
  321.     my $old = $self->{'_netscape_comment'};
  322.     $self->{'_netscape_comment'} = shift if @_;
  323.     return $old;
  324. }
  325.  
  326. sub parse_file
  327. {
  328.     my($self, $file) = @_;
  329.     no strict 'refs';  # so that a symbol ref as $file works
  330.     local(*F);
  331.     unless (ref($file) || $file =~ /^\*[\w:]+$/) {
  332.     # Assume $file is a filename
  333.     open(F, $file) || die "Can't open $file: $!";
  334.     $file = \*F;
  335.     }
  336.     my $chunk = '';
  337.     while(read($file, $chunk, 2048)) {
  338.     $self->parse($chunk);
  339.     }
  340.     close($file);
  341.     $self->eof;
  342. }
  343.  
  344. sub text
  345. {
  346.     # my($self, $text) = @_;
  347. }
  348.  
  349. sub declaration
  350. {
  351.     # my($self, $decl) = @_;
  352. }
  353.  
  354. sub comment
  355. {
  356.     # my($self, $comment) = @_;
  357. }
  358.  
  359. sub start
  360. {
  361.     my($self, $tag, $attr, $attrseq, $origtext) = @_;
  362.     # $attr is reference to a HASH, $attrseq is reference to an ARRAY
  363. }
  364.  
  365. sub end
  366. {
  367.     my($self, $tag) = @_;
  368. }
  369.  
  370. 1;
  371.