home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / HTML / HeadParser.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  5.8 KB  |  250 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. $VERSION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);
  81.  
  82. my $FINISH = "HEAD PARSED\n";
  83.  
  84. =item $hp = HTML::HeadParser->new( [$header] )
  85.  
  86. =cut
  87.  
  88. sub new
  89. {
  90.     my($class, $header) = @_;
  91.     $header ||= HTTP::Headers->new;
  92.     my $self = bless HTML::Parser->new, $class;
  93.     $self->{'header'} = $header;
  94.     $self->{'tag'} = '';   # name of active element that takes textual content
  95.     $self->{'text'} = '';  # the accumulated text associated with the element
  96.     $self;
  97. }
  98.  
  99. =item $hp->parse( $text )
  100.  
  101. Parses some HTML text (see HTML::Parser->parse()) but will return
  102. FALSE as soon as parsing should end.
  103.  
  104. =cut
  105.  
  106. sub parse
  107. {
  108.     my $self = shift;
  109.     eval { $self->SUPER::parse(@_) };
  110.     if ($@) {
  111.         print $@ if $DEBUG;
  112.     $self->{'_buf'} = '';  # flush rest of buffer
  113.     return '';
  114.     }
  115.     $self;
  116. }
  117.  
  118. =item $hp->header;
  119.  
  120. Returns a reference to the HTML::Header object.
  121.  
  122. =item $hp->header( $key )
  123.  
  124. Returns a header value.
  125.  
  126. =cut
  127.  
  128. sub header
  129. {
  130.     my $self = shift;
  131.     return $self->{'header'} unless @_;
  132.     $self->{'header'}->header(@_);
  133. }
  134.  
  135. =item $hp->as_string;
  136.  
  137. Same as $hp->header->as_string
  138.  
  139. =cut
  140.  
  141. sub as_string
  142. {
  143.     my $self = shift;
  144.     $self->{'header'}->as_string;
  145. }
  146.  
  147. sub flush_text   # internal
  148. {
  149.     my $self = shift;
  150.     my $tag  = $self->{'tag'};
  151.     my $text = $self->{'text'};
  152.     $text =~ s/^\s+//; 
  153.     $text =~ s/\s+$//; 
  154.     $text =~ s/\s+/ /g;
  155.     print "FLUSH $tag => '$text'\n"  if $DEBUG;
  156.     if ($tag eq 'title') {
  157.     $self->{'header'}->header(title => $text);
  158.     }
  159.     $self->{'tag'} = $self->{'text'} = '';
  160. }
  161.  
  162.  
  163.  
  164. sub start
  165. {
  166.     my($self, $tag, $attr) = @_;  # $attr is reference to a HASH
  167.     print "START[$tag]\n" if $DEBUG;
  168.     $self->flush_text if $self->{'tag'};
  169.     if ($tag eq 'meta') {
  170.     my $key = $attr->{'http-equiv'};
  171.     if (!defined $key) {
  172.         return unless $attr->{'name'};
  173.         $key = "X-Meta-\u$attr->{'name'}";
  174.     }
  175.     $self->{'header'}->push_header($key => $attr->{content});
  176.     } elsif ($tag eq 'base') {
  177.     return unless exists $attr->{href};
  178.     $self->{'header'}->header('Content-Base' => $attr->{href});
  179.     } elsif ($tag eq 'isindex') {
  180.     $self->{'header'}->header(Isindex => $attr->{prompt} || '?');
  181.     } elsif ($tag =~ /^(?:title|script|style)$/) {
  182.     $self->{'tag'} = $tag;
  183.     } elsif ($tag eq 'link') {
  184.     return unless exists $attr->{href};
  185.     my $h_val = "<" . delete($attr->{href}) . ">";
  186.     for (sort keys %{$attr}) {
  187.         $h_val .= qq(; $_="$attr->{$_}");
  188.     }
  189.     $self->{'header'}->header(Link => $h_val);
  190.     } elsif ($tag eq 'head' || $tag eq 'html') {
  191.     } else {
  192.     die $FINISH;
  193.     }
  194. }
  195.  
  196. sub end
  197. {
  198.     my($self, $tag) = @_;
  199.     print "END[$tag]\n" if $DEBUG;
  200.     $self->flush_text if $self->{'tag'};
  201.     die $FINISH if $tag eq 'head';
  202. }
  203.  
  204. sub text
  205. {
  206.     my($self, $text) = @_;
  207.     print "TEXT[$text]\n" if $DEBUG;
  208.     my $tag = $self->{tag};
  209.     if (!$tag && $text =~ /\S/) {
  210.     die $FINISH;
  211.     }
  212.     return if $tag ne 'title';  # optimize skipping of <script> and <style>
  213.     HTML::Entities::decode($text);
  214.     $self->{'text'} .= $text;
  215. }
  216.  
  217. 1;
  218.  
  219. __END__
  220.  
  221. =head1 EXAMPLES
  222.  
  223.  $h = HTTP::Headers->new;
  224.  $p = HTML::HeadParser->new($h);
  225.  $p->parse(<<EOT);
  226.  <title>Stupid example</title>
  227.  <base href="http://www.sn.no/libwww-perl/">
  228.  Normal text starts here.
  229.  EOT
  230.  undef $p;
  231.  print $h->title;   # should print "Stupid example"
  232.  
  233. =head1 SEE ALSO
  234.  
  235. L<HTML::Parser>, L<HTTP::Headers>
  236.  
  237. =head1 COPYRIGHT
  238.  
  239. Copyright 1996-1997 Gisle Aas. All rights reserved.
  240.  
  241. This library is free software; you can redistribute it and/or
  242. modify it under the same terms as Perl itself.
  243.  
  244. =head1 AUTHOR
  245.  
  246. Gisle Aas E<lt>aas@sn.no>
  247.  
  248. =cut
  249.  
  250.