home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _c41ed8847e473e6bfb64772ea392b294 < prev    next >
Text File  |  2000-03-15  |  7KB  |  288 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>
  21. section of an HTML document.  The parse() method
  22. will return a FALSE value as soon as some E<lt>BODY> element or body
  23. text are found, and should not be called again after this.
  24.  
  25. The I<HTML::HeadParser> keeps a reference to a header object, and the
  26. parser will update this header object as the various elements of the
  27. E<lt>HEAD> section of the HTML document are recognized.  The following
  28. header fields are affected:
  29.  
  30. =over 4
  31.  
  32. =item Content-Base:
  33.  
  34. The I<Content-Base> header is initialized from the E<lt>base
  35. href="..."> element.
  36.  
  37. =item Title:
  38.  
  39. The I<Title> header is initialized from the E<lt>title>...E<lt>/title>
  40. element.
  41.  
  42. =item Isindex:
  43.  
  44. The I<Isindex> header will be added if there is a E<lt>isindex>
  45. element in the E<lt>head>.  The header value is initialized from the
  46. I<prompt> attribute if it is present.  If not I<prompt> attribute is
  47. given it will have '?' as the value.
  48.  
  49. =item X-Meta-Foo:
  50.  
  51. All E<lt>meta> elements will initialize headers with the prefix
  52. "C<X-Meta->" on the name.  If the E<lt>meta> element contains a
  53. C<http-equiv> attribute, then it will be honored as the header name.
  54.  
  55. =back
  56.  
  57. =head1 METHODS
  58.  
  59. The following methods (in addition to those provided by the
  60. superclass) are available:
  61.  
  62. =over 4
  63.  
  64. =cut
  65.  
  66.  
  67. require HTML::Parser;
  68. @ISA = qw(HTML::Parser);
  69.  
  70. use HTML::Entities ();
  71.  
  72. use strict;
  73. use vars qw($VERSION $DEBUG);
  74. #$DEBUG = 1;
  75. $VERSION = sprintf("%d.%02d", q$Revision: 2.10 $ =~ /(\d+)\.(\d+)/);
  76.  
  77. my $FINISH = "HEAD PARSED\n";
  78.  
  79. =item $hp = HTML::HeadParser->new( [$header] )
  80.  
  81. The object constructor.  The optional $header argument should be a
  82. reference to an object that implement the header() and push_header()
  83. methods as defined by the I<HTTP::Headers> class.  Normally it will be
  84. of some class that isa or delegates to the I<HTTP::Headers> class.
  85.  
  86. If no $header is given I<HTML::HeadParser> will create an
  87. I<HTTP::Header> object by itself (initially empty).
  88.  
  89. =cut
  90.  
  91. sub new
  92. {
  93.     my($class, $header) = @_;
  94.     unless ($header) {
  95.     require HTTP::Headers;
  96.     $header = HTTP::Headers->new;
  97.     }
  98.  
  99.     my $self = $class->SUPER::new;
  100.     $self->{'header'} = $header;
  101.     $self->{'tag'} = '';   # name of active element that takes textual content
  102.     $self->{'text'} = '';  # the accumulated text associated with the element
  103.     $self;
  104. }
  105.  
  106. =item $hp->parse( $text )
  107.  
  108. Parses some HTML text (see HTML::Parser->parse()) but will return
  109. FALSE as soon as parsing should end.
  110.  
  111. =cut
  112.  
  113. sub parse
  114. {
  115.     my $self = shift;
  116.     eval {
  117.     local $SIG{__DIE__};
  118.     $self->SUPER::parse(@_)
  119.     };
  120.     if ($@) {
  121.         print $@ if $DEBUG;
  122.     $self->{'_buf'} = '';  # flush rest of buffer
  123.     return '';
  124.     }
  125.     $self;
  126. }
  127.  
  128. # more code duplication than I would like, but we need to treat the
  129. # return value from $self->parse as a signal to stop parsing.
  130. sub parse_file
  131. {
  132.     my($self, $file) = @_;
  133.     no strict 'refs';  # so that a symbol ref as $file works
  134.     local(*F);
  135.     unless (ref($file) || $file =~ /^\*[\w:]+$/) {
  136.         # Assume $file is a filename
  137.         open(F, $file) || die "Can't open $file: $!";
  138.         $file = \*F;
  139.     }
  140.     my $chunk = '';
  141.     while(read($file, $chunk, 512)) {
  142.         $self->parse($chunk) || last;
  143.     }
  144.     close($file);
  145.     return $self;
  146. }
  147.  
  148. =item $hp->header;
  149.  
  150. Returns a reference to the header object.
  151.  
  152. =item $hp->header( $key )
  153.  
  154. Returns a header value.  It is just a shorter way to write
  155. C<$hp-E<gt>header-E<gt>header($key)>.
  156.  
  157. =cut
  158.  
  159. sub header
  160. {
  161.     my $self = shift;
  162.     return $self->{'header'} unless @_;
  163.     $self->{'header'}->header(@_);
  164. }
  165.  
  166. sub as_string    # legacy
  167. {
  168.     my $self = shift;
  169.     $self->{'header'}->as_string;
  170. }
  171.  
  172. sub flush_text   # internal
  173. {
  174.     my $self = shift;
  175.     my $tag  = $self->{'tag'};
  176.     my $text = $self->{'text'};
  177.     $text =~ s/^\s+//; 
  178.     $text =~ s/\s+$//; 
  179.     $text =~ s/\s+/ /g;
  180.     print "FLUSH $tag => '$text'\n"  if $DEBUG;
  181.     if ($tag eq 'title') {
  182.     $self->{'header'}->header(Title => $text);
  183.     }
  184.     $self->{'tag'} = $self->{'text'} = '';
  185. }
  186.  
  187. # This is an quote from the HTML3.2 DTD which shows which elements
  188. # that might be present in a <HEAD>...</HEAD>.  Also note that the
  189. # <HEAD> tags themselves might be missing:
  190. #
  191. # <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? &
  192. #                            SCRIPT* & META* & LINK*">
  193. # 
  194. # <!ELEMENT HEAD O O  (%head.content)>
  195.  
  196.  
  197. sub start
  198. {
  199.     my($self, $tag, $attr) = @_;  # $attr is reference to a HASH
  200.     print "START[$tag]\n" if $DEBUG;
  201.     $self->flush_text if $self->{'tag'};
  202.     if ($tag eq 'meta') {
  203.     my $key = $attr->{'http-equiv'};
  204.     if (!defined $key) {
  205.         return unless $attr->{'name'};
  206.         $key = "X-Meta-\u$attr->{'name'}";
  207.     }
  208.     $self->{'header'}->push_header($key => $attr->{content});
  209.     } elsif ($tag eq 'base') {
  210.     return unless exists $attr->{href};
  211.     $self->{'header'}->header('Content-Base' => $attr->{href});
  212.     } elsif ($tag eq 'isindex') {
  213.     # This is a non-standard header.  Perhaps we should just ignore
  214.     # this element
  215.     $self->{'header'}->header(Isindex => $attr->{prompt} || '?');
  216.     } elsif ($tag =~ /^(?:title|script|style)$/) {
  217.     # Just remember tag.  Initialize header when we see the end tag.
  218.     $self->{'tag'} = $tag;
  219.     } elsif ($tag eq 'link') {
  220.     return unless exists $attr->{href};
  221.     # <link href="http:..." rel="xxx" rev="xxx" title="xxx">
  222.     my $h_val = "<" . delete($attr->{href}) . ">";
  223.     for (sort keys %{$attr}) {
  224.         $h_val .= qq(; $_="$attr->{$_}");
  225.     }
  226.     $self->{'header'}->header(Link => $h_val);
  227.     } elsif ($tag eq 'head' || $tag eq 'html') {
  228.     # ignore
  229.     } else {
  230.     die $FINISH;
  231.     }
  232. }
  233.  
  234. sub end
  235. {
  236.     my($self, $tag) = @_;
  237.     print "END[$tag]\n" if $DEBUG;
  238.     $self->flush_text if $self->{'tag'};
  239.     die $FINISH if $tag eq 'head';
  240. }
  241.  
  242. sub text
  243. {
  244.     my($self, $text) = @_;
  245.     print "TEXT[$text]\n" if $DEBUG;
  246.     my $tag = $self->{tag};
  247.     if (!$tag && $text =~ /\S/) {
  248.     # Normal text means start of body
  249.     die $FINISH;
  250.     }
  251.     return if $tag ne 'title';  # optimize skipping of <script> and <style>
  252.     HTML::Entities::decode($text);
  253.     $self->{'text'} .= $text;
  254. }
  255.  
  256. 1;
  257.  
  258. __END__
  259.  
  260. =head1 EXAMPLE
  261.  
  262.  $h = HTTP::Headers->new;
  263.  $p = HTML::HeadParser->new($h);
  264.  $p->parse(<<EOT);
  265.  <title>Stupid example</title>
  266.  <base href="http://www.sn.no/libwww-perl/">
  267.  Normal text starts here.
  268.  EOT
  269.  undef $p;
  270.  print $h->title;   # should print "Stupid example"
  271.  
  272. =head1 SEE ALSO
  273.  
  274. L<HTML::Parser>, L<HTTP::Headers>
  275.  
  276. The I<HTTP::Headers> class is distributed as part of the I<libwww-perl>
  277. package.
  278.  
  279. =head1 COPYRIGHT
  280.  
  281. Copyright 1996-1998 Gisle Aas. All rights reserved.
  282.  
  283. This library is free software; you can redistribute it and/or
  284. modify it under the same terms as Perl itself.
  285.  
  286. =cut
  287.  
  288.