home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / HTML / HeadParser.pm < prev    next >
Text File  |  1997-06-26  |  6KB  |  265 lines
  1. package HTML::HeadParser;
  2.  
  3. =head1 NAME
  4.  
  5. HTML::HeadParser - Parse <HEAD> section of a HTML document
  6.  
  7. =head1 SYNOPSIS
  8.  
  9.  require HTML::HeadParser;
  10.  $p = HTML::HeadParser->new;
  11.  $p->parse($text) and  print "not finished";
  12.  
  13.  $p->header('Title')          # to access <title>....</title>
  14.  $p->header('Content-Base')   # to access <base href="http://...">
  15.  $p->header('Foo')            # to access <meta http-equiv="Foo" content="...">
  16.  
  17. =head1 DESCRIPTION
  18.  
  19. The I<HTML::HeadParser> is a specialized (and lightweight)
  20. I<HTML::Parser> that will only parse the E<lt>HEAD>...E<lt>/HEAD> section of a
  21. HTML document.  The parse() and parse_file() methods will return a
  22. FALSE value as soon as a E<lt>BODY> element is found, and should not be
  23. called again after this.
  24.  
  25. The I<HTML::HeadParser> constructor takes an optional I<HTTP::Headers>
  26. object reference as argument.  The parser will update this header
  27. object as the various E<lt>HEAD> elements are recognized.  If no
  28. header is given we will create an internal (and initially empty)
  29. header object.  This header object can be accessed with the header()
  30. method.
  31.  
  32. The following header fields are initialized from elements found in the
  33. E<lt>HEAD> section of the HTML document:
  34.  
  35. =over 4
  36.  
  37. =item Content-Base:
  38.  
  39. The I<Content-Base> header is initialized from the E<lt>base
  40. href="..."> element.
  41.  
  42. =item Title:
  43.  
  44. The I<Title> header is initialized from the E<lt>title>...E<lt>/title>
  45. element.
  46.  
  47. =item Isindex:
  48.  
  49. The I<Isindex> header will be added if there is a E<lt>isindex>
  50. element in the E<lt>head>.  The header value is initialized from the
  51. I<prompt> attribute if it is present.  If not I<prompt> attribute is
  52. given it will have '?' as the value.
  53.  
  54. =item X-Meta-Foo
  55.  
  56. All E<lt>meta> elements will initialize headers with the prefix
  57. "X-Meta-".  If the element contains a I<http-equiv> attribute, then it
  58. will be honored as the header name.
  59.  
  60. =back
  61.  
  62. =head1 METHODS
  63.  
  64. The following methods (in addition to those provided by the
  65. superclass) are available:
  66.  
  67. =over 4
  68.  
  69. =cut
  70.  
  71.  
  72. require HTML::Parser;
  73. @ISA = qw(HTML::Parser);
  74.  
  75. use HTML::Entities ();
  76. require HTTP::Headers;
  77.  
  78. use strict;
  79. use vars qw($VERSION $DEBUG);
  80. #$DEBUG = 1;
  81. $VERSION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);
  82.  
  83. my $FINISH = "HEAD PARSED\n";
  84.  
  85. =item $hp = HTML::HeadParser->new( [$header] )
  86.  
  87. =cut
  88.  
  89. sub new
  90. {
  91.     my($class, $header) = @_;
  92.     $header ||= HTTP::Headers->new;
  93.     my $self = bless HTML::Parser->new, $class;
  94.     $self->{'header'} = $header;
  95.     $self->{'tag'} = '';   # name of active element that takes textual content
  96.     $self->{'text'} = '';  # the accumulated text associated with the element
  97.     $self;
  98. }
  99.  
  100. =item $hp->parse( $text )
  101.  
  102. Parses some HTML text (see HTML::Parser->parse()) but will return
  103. FALSE as soon as parsing should end.
  104.  
  105. =cut
  106.  
  107. sub parse
  108. {
  109.     my $self = shift;
  110.     eval { $self->SUPER::parse(@_) };
  111.     if ($@) {
  112.         print $@ if $DEBUG;
  113.     $self->{'_buf'} = '';  # flush rest of buffer
  114.     return '';
  115.     }
  116.     $self;
  117. }
  118.  
  119. =item $hp->header;
  120.  
  121. Returns a reference to the HTML::Header object.
  122.  
  123. =item $hp->header( $key )
  124.  
  125. Returns a header value.
  126.  
  127. =cut
  128.  
  129. sub header
  130. {
  131.     my $self = shift;
  132.     return $self->{'header'} unless @_;
  133.     $self->{'header'}->header(@_);
  134. }
  135.  
  136. =item $hp->as_string;
  137.  
  138. Same as $hp->header->as_string
  139.  
  140. =cut
  141.  
  142. sub as_string
  143. {
  144.     my $self = shift;
  145.     $self->{'header'}->as_string;
  146. }
  147.  
  148. sub flush_text   # internal
  149. {
  150.     my $self = shift;
  151.     my $tag  = $self->{'tag'};
  152.     my $text = $self->{'text'};
  153.     $text =~ s/^\s+//; 
  154.     $text =~ s/\s+$//; 
  155.     $text =~ s/\s+/ /g;
  156.     print "FLUSH $tag => '$text'\n"  if $DEBUG;
  157.     if ($tag eq 'title') {
  158.     $self->{'header'}->header(title => $text);
  159.     }
  160.     $self->{'tag'} = $self->{'text'} = '';
  161. }
  162.  
  163. # This is an quote from the HTML3.2 DTD which shows which elements
  164. # that might be present in a <HEAD>...</HEAD>.  Also note that the
  165. # <HEAD> tags themselves might be missing:
  166. #
  167. # <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? &
  168. #                            SCRIPT* & META* & LINK*">
  169. # 
  170. # <!ELEMENT HEAD O O  (%head.content)>
  171.  
  172.  
  173. sub start
  174. {
  175.     my($self, $tag, $attr) = @_;  # $attr is reference to a HASH
  176.     print "START[$tag]\n" if $DEBUG;
  177.     $self->flush_text if $self->{'tag'};
  178.     if ($tag eq 'meta') {
  179.     my $key = $attr->{'http-equiv'};
  180.     if (!defined $key) {
  181.         return unless $attr->{'name'};
  182.         $key = "X-Meta-\u$attr->{'name'}";
  183.     }
  184.     $self->{'header'}->push_header($key => $attr->{content});
  185.     } elsif ($tag eq 'base') {
  186.     return unless exists $attr->{href};
  187.     $self->{'header'}->header('Content-Base' => $attr->{href});
  188.     } elsif ($tag eq 'isindex') {
  189.     # This is a non-standard header.  Perhaps we should just ignore
  190.     # this element
  191.     $self->{'header'}->header(Isindex => $attr->{prompt} || '?');
  192.     } elsif ($tag =~ /^(?:title|script|style)$/) {
  193.     # Just remember tag.  Initialize header when we see the end tag.
  194.     $self->{'tag'} = $tag;
  195.     } elsif ($tag eq 'link') {
  196.     return unless exists $attr->{href};
  197.     # <link href="http:..." rel="xxx" rev="xxx" title="xxx">
  198.     my $h_val = "<" . delete($attr->{href}) . ">";
  199.     for (sort keys %{$attr}) {
  200.         $h_val .= qq(; $_="$attr->{$_}");
  201.     }
  202.     $self->{'header'}->header(Link => $h_val);
  203.     } elsif ($tag eq 'head' || $tag eq 'html') {
  204.     # ignore
  205.     } else {
  206.     die $FINISH;
  207.     }
  208. }
  209.  
  210. sub end
  211. {
  212.     my($self, $tag) = @_;
  213.     print "END[$tag]\n" if $DEBUG;
  214.     $self->flush_text if $self->{'tag'};
  215.     die $FINISH if $tag eq 'head';
  216. }
  217.  
  218. sub text
  219. {
  220.     my($self, $text) = @_;
  221.     print "TEXT[$text]\n" if $DEBUG;
  222.     my $tag = $self->{tag};
  223.     if (!$tag && $text =~ /\S/) {
  224.     # Normal text means start of body
  225.     die $FINISH;
  226.     }
  227.     return if $tag ne 'title';  # optimize skipping of <script> and <style>
  228.     HTML::Entities::decode($text);
  229.     $self->{'text'} .= $text;
  230. }
  231.  
  232. 1;
  233.  
  234. __END__
  235.  
  236. =head1 EXAMPLES
  237.  
  238.  $h = HTTP::Headers->new;
  239.  $p = HTML::HeadParser->new($h);
  240.  $p->parse(<<EOT);
  241.  <title>Stupid example</title>
  242.  <base href="http://www.sn.no/libwww-perl/">
  243.  Normal text starts here.
  244.  EOT
  245.  undef $p;
  246.  print $h->title;   # should print "Stupid example"
  247.  
  248. =head1 SEE ALSO
  249.  
  250. L<HTML::Parser>, L<HTTP::Headers>
  251.  
  252. =head1 COPYRIGHT
  253.  
  254. Copyright 1996-1997 Gisle Aas. All rights reserved.
  255.  
  256. This library is free software; you can redistribute it and/or
  257. modify it under the same terms as Perl itself.
  258.  
  259. =head1 AUTHOR
  260.  
  261. Gisle Aas E<lt>aas@sn.no>
  262.  
  263. =cut
  264.  
  265.