local-lib5/lib/perl5/i486-linux-gnu-thread-multi/HTML/HeadParser.pm

   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  $p->header('X-Meta-Author')  # to access <meta name="author" content="...">
  17  $p->header('X-Meta-Charset') # to access <meta charset="...">
  18
  19 =head1 DESCRIPTION
  20
  21 The C<HTML::HeadParser> is a specialized (and lightweight)
  22 C<HTML::Parser> that will only parse the E<lt>HEAD>...E<lt>/HEAD>
  23 section of an HTML document.  The parse() method
  24 will return a FALSE value as soon as some E<lt>BODY> element or body
  25 text are found, and should not be called again after this.
  26
  27 Note that the C<HTML::HeadParser> might get confused if raw undecoded
  28 UTF-8 is passed to the parse() method.  Make sure the strings are
  29 properly decoded before passing them on.
  30
  31 The C<HTML::HeadParser> keeps a reference to a header object, and the
  32 parser will update this header object as the various elements of the
  33 E<lt>HEAD> section of the HTML document are recognized.  The following
  34 header fields are affected:
  35
  36 =over 4
  37
  38 =item Content-Base:
  39
  40 The I<Content-Base> header is initialized from the E<lt>base
  41 href="..."> element.
  42
  43 =item Title:
  44
  45 The I<Title> header is initialized from the E<lt>title>...E<lt>/title>
  46 element.
  47
  48 =item Isindex:
  49
  50 The I<Isindex> header will be added if there is a E<lt>isindex>
  51 element in the E<lt>head>.  The header value is initialized from the
  52 I<prompt> attribute if it is present.  If no I<prompt> attribute is
  53 given it will have '?' as the value.
  54
  55 =item X-Meta-Foo:
  56
  57 All E<lt>meta> elements containing a C<name> attribute will result in
  58 headers using the prefix C<X-Meta-> appended with the value of the
  59 C<name> attribute as the name of the header, and the value of the
  60 C<content> attribute as the pushed header value.
  61
  62 E<lt>meta> elements containing a C<http-equiv> attribute will result
  63 in headers as in above, but without the C<X-Meta-> prefix in the
  64 header name.
  65
  66 E<lt>meta> elements containing a C<charset> attribute will result in
  67 an C<X-Meta-Charset> header, using the value of the C<charset>
  68 attribute as the pushed header value.
  69
  70 =back
  71
  72 =head1 METHODS
  73
  74 The following methods (in addition to those provided by the
  75 superclass) are available:
  76
  77 =over 4
  78
  79 =cut
  80
  81
  82 require HTML::Parser;
  83 @ISA = qw(HTML::Parser);
  84
  85 use HTML::Entities ();
  86
  87 use strict;
  88 use vars qw($VERSION $DEBUG);
  89 #$DEBUG = 1;
  90 $VERSION = "3.62";
  91
  92 =item $hp = HTML::HeadParser->new
  93
  94 =item $hp = HTML::HeadParser->new( $header )
  95
  96 The object constructor.  The optional $header argument should be a
  97 reference to an object that implement the header() and push_header()
  98 methods as defined by the C<HTTP::Headers> class.  Normally it will be
  99 of some class that is a or delegates to the C<HTTP::Headers> class.
 100
 101 If no $header is given C<HTML::HeadParser> will create an
 102 C<HTTP::Headers> object by itself (initially empty).
 103
 104 =cut
 105
 106 sub new
 107 {
 108     my($class, $header) = @_;
 109     unless ($header) {
 110         require HTTP::Headers;
 111         $header = HTTP::Headers->new;
 112     }
 113
 114     my $self = $class->SUPER::new(api_version => 3,
 115                                   start_h => ["start", "self,tagname,attr"],
 116                                   end_h   => ["end",   "self,tagname"],
 117                                   text_h  => ["text",  "self,text"],
 118                                   ignore_elements => [qw(script style)],
 119                                  );
 120     $self->{'header'} = $header;
 121     $self->{'tag'} = '';   # name of active element that takes textual content
 122     $self->{'text'} = '';  # the accumulated text associated with the element
 123     $self;
 124 }
 125
 126 =item $hp->header;
 127
 128 Returns a reference to the header object.
 129
 130 =item $hp->header( $key )
 131
 132 Returns a header value.  It is just a shorter way to write
 133 C<$hp-E<gt>header-E<gt>header($key)>.
 134
 135 =cut
 136
 137 sub header
 138 {
 139     my $self = shift;
 140     return $self->{'header'} unless @_;
 141     $self->{'header'}->header(@_);
 142 }
 143
 144 sub as_string    # legacy
 145 {
 146     my $self = shift;
 147     $self->{'header'}->as_string;
 148 }
 149
 150 sub flush_text   # internal
 151 {
 152     my $self = shift;
 153     my $tag  = $self->{'tag'};
 154     my $text = $self->{'text'};
 155     $text =~ s/^\s+//;
 156     $text =~ s/\s+$//;
 157     $text =~ s/\s+/ /g;
 158     print "FLUSH $tag => '$text'\n"  if $DEBUG;
 159     if ($tag eq 'title') {
 160         HTML::Entities::decode($text);
 161         $self->{'header'}->push_header(Title => $text);
 162     }
 163     $self->{'tag'} = $self->{'text'} = '';
 164 }
 165
 166 # This is an quote from the HTML3.2 DTD which shows which elements
 167 # that might be present in a <HEAD>...</HEAD>.  Also note that the
 168 # <HEAD> tags themselves might be missing:
 169 #
 170 # <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? &
 171 #                            SCRIPT* & META* & LINK*">
 172 #
 173 # <!ELEMENT HEAD O O  (%head.content)>
 174 #
 175 # From HTML 4.01:
 176 #
 177 # <!ENTITY % head.misc "SCRIPT|STYLE|META|LINK|OBJECT">
 178 # <!ENTITY % head.content "TITLE & BASE?">
 179 # <!ELEMENT HEAD O O (%head.content;) +(%head.misc;)>
 180 #
 181 # Added in HTML 5 as of WD-html5-20090423: noscript, command
 182
 183 sub start
 184 {
 185     my($self, $tag, $attr) = @_;  # $attr is reference to a HASH
 186     print "START[$tag]\n" if $DEBUG;
 187     $self->flush_text if $self->{'tag'};
 188     if ($tag eq 'meta') {
 189         my $key = $attr->{'http-equiv'};
 190         if (!defined($key) || !length($key)) {
 191             if ($attr->{name}) {
 192                 $key = "X-Meta-\u$attr->{name}";
 193             } elsif ($attr->{charset}) { # HTML 5 <meta charset="...">
 194                 $key = "X-Meta-Charset";
 195                 $self->{header}->push_header($key => $attr->{charset});
 196                 return;
 197             } else {
 198                 return;
 199             }
 200         }
 201         $self->{'header'}->push_header($key => $attr->{content});
 202     } elsif ($tag eq 'base') {
 203         return unless exists $attr->{href};
 204         $self->{'header'}->push_header('Content-Base' => $attr->{href});
 205     } elsif ($tag eq 'isindex') {
 206         # This is a non-standard header.  Perhaps we should just ignore
 207         # this element
 208         $self->{'header'}->push_header(Isindex => $attr->{prompt} || '?');
 209     } elsif ($tag =~ /^(?:title|noscript|object|command)$/) {
 210         # Just remember tag.  Initialize header when we see the end tag.
 211         $self->{'tag'} = $tag;
 212     } elsif ($tag eq 'link') {
 213         return unless exists $attr->{href};
 214         # <link href="http:..." rel="xxx" rev="xxx" title="xxx">
 215         my $h_val = "<" . delete($attr->{href}) . ">";
 216         for (sort keys %{$attr}) {
 217             next if $_ eq "/";  # XHTML junk
 218             $h_val .= qq(; $_="$attr->{$_}");
 219         }
 220         $self->{'header'}->push_header(Link => $h_val);
 221     } elsif ($tag eq 'head' || $tag eq 'html') {
 222         # ignore
 223     } else {
 224          # stop parsing
 225         $self->eof;
 226     }
 227 }
 228
 229 sub end
 230 {
 231     my($self, $tag) = @_;
 232     print "END[$tag]\n" if $DEBUG;
 233     $self->flush_text if $self->{'tag'};
 234     $self->eof if $tag eq 'head';
 235 }
 236
 237 sub text
 238 {
 239     my($self, $text) = @_;
 240     print "TEXT[$text]\n" if $DEBUG;
 241     unless ($self->{first_chunk}) {
 242         # drop Unicode BOM if found
 243         if ($self->utf8_mode) {
 244             $text =~ s/^\xEF\xBB\xBF//;
 245         }
 246         else {
 247             $text =~ s/^\x{FEFF}//;
 248         }
 249         $self->{first_chunk}++;
 250     }
 251     my $tag = $self->{tag};
 252     if (!$tag && $text =~ /\S/) {
 253         # Normal text means start of body
 254         $self->eof;
 255         return;
 256     }
 257     return if $tag ne 'title';
 258     $self->{'text'} .= $text;
 259 }
 260
 261 BEGIN {
 262     *utf8_mode = sub { 1 } unless HTML::Entities::UNICODE_SUPPORT;;
 263 }
 264
 265 1;
 266
 267 __END__
 268
 269 =back
 270
 271 =head1 EXAMPLE
 272
 273  $h = HTTP::Headers->new;
 274  $p = HTML::HeadParser->new($h);
 275  $p->parse(<<EOT);
 276  <title>Stupid example</title>
 277  <base href="http://www.linpro.no/lwp/">
 278  Normal text starts here.
 279  EOT
 280  undef $p;
 281  print $h->title;   # should print "Stupid example"
 282
 283 =head1 SEE ALSO
 284
 285 L<HTML::Parser>, L<HTTP::Headers>
 286
 287 The C<HTTP::Headers> class is distributed as part of the
 288 I<libwww-perl> package.  If you don't have that distribution installed
 289 you need to provide the $header argument to the C<HTML::HeadParser>
 290 constructor with your own object that implements the documented
 291 protocol.
 292
 293 =head1 COPYRIGHT
 294
 295 Copyright 1996-2001 Gisle Aas. All rights reserved.
 296
 297 This library is free software; you can redistribute it and/or
 298 modify it under the same terms as Perl itself.
 299
 300 =cut
 301