home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / HTML / HeadParser.pm < prev    next >
Encoding:
Perl POD Document  |  2010-07-09  |  8.0 KB  |  308 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.  $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.66";
  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.     my $decoded;
  161.     $decoded = utf8::decode($text) if $self->utf8_mode && defined &utf8::decode;
  162.     HTML::Entities::decode($text);
  163.     utf8::encode($text) if $decoded;
  164.     $self->{'header'}->push_header(Title => $text);
  165.     }
  166.     $self->{'tag'} = $self->{'text'} = '';
  167. }
  168.  
  169. # This is an quote from the HTML3.2 DTD which shows which elements
  170. # that might be present in a <HEAD>...</HEAD>.  Also note that the
  171. # <HEAD> tags themselves might be missing:
  172. #
  173. # <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? &
  174. #                            SCRIPT* & META* & LINK*">
  175. #
  176. # <!ELEMENT HEAD O O  (%head.content)>
  177. #
  178. # From HTML 4.01:
  179. #
  180. # <!ENTITY % head.misc "SCRIPT|STYLE|META|LINK|OBJECT">
  181. # <!ENTITY % head.content "TITLE & BASE?">
  182. # <!ELEMENT HEAD O O (%head.content;) +(%head.misc;)>
  183. #
  184. # From HTML 5 as of WD-html5-20090825:
  185. #
  186. # One or more elements of metadata content, [...]
  187. # => base, command, link, meta, noscript, script, style, title
  188.  
  189. sub start
  190. {
  191.     my($self, $tag, $attr) = @_;  # $attr is reference to a HASH
  192.     print "START[$tag]\n" if $DEBUG;
  193.     $self->flush_text if $self->{'tag'};
  194.     if ($tag eq 'meta') {
  195.     my $key = $attr->{'http-equiv'};
  196.     if (!defined($key) || !length($key)) {
  197.         if ($attr->{name}) {
  198.         $key = "X-Meta-\u$attr->{name}";
  199.         } elsif ($attr->{charset}) { # HTML 5 <meta charset="...">
  200.         $key = "X-Meta-Charset";
  201.         $self->{header}->push_header($key => $attr->{charset});
  202.         return;
  203.         } else {
  204.         return;
  205.         }
  206.     }
  207.     $self->{'header'}->push_header($key => $attr->{content});
  208.     } elsif ($tag eq 'base') {
  209.     return unless exists $attr->{href};
  210.     $self->{'header'}->push_header('Content-Base' => $attr->{href});
  211.     } elsif ($tag eq 'isindex') {
  212.     # This is a non-standard header.  Perhaps we should just ignore
  213.     # this element
  214.     $self->{'header'}->push_header(Isindex => $attr->{prompt} || '?');
  215.     } elsif ($tag =~ /^(?:title|noscript|object|command)$/) {
  216.     # Just remember tag.  Initialize header when we see the end tag.
  217.     $self->{'tag'} = $tag;
  218.     } elsif ($tag eq 'link') {
  219.     return unless exists $attr->{href};
  220.     # <link href="http:..." rel="xxx" rev="xxx" title="xxx">
  221.     my $h_val = "<" . delete($attr->{href}) . ">";
  222.     for (sort keys %{$attr}) {
  223.         next if $_ eq "/";  # XHTML junk
  224.         $h_val .= qq(; $_="$attr->{$_}");
  225.     }
  226.     $self->{'header'}->push_header(Link => $h_val);
  227.     } elsif ($tag eq 'head' || $tag eq 'html') {
  228.     # ignore
  229.     } else {
  230.      # stop parsing
  231.     $self->eof;
  232.     }
  233. }
  234.  
  235. sub end
  236. {
  237.     my($self, $tag) = @_;
  238.     print "END[$tag]\n" if $DEBUG;
  239.     $self->flush_text if $self->{'tag'};
  240.     $self->eof if $tag eq 'head';
  241. }
  242.  
  243. sub text
  244. {
  245.     my($self, $text) = @_;
  246.     print "TEXT[$text]\n" if $DEBUG;
  247.     unless ($self->{first_chunk}) {
  248.     # drop Unicode BOM if found
  249.     if ($self->utf8_mode) {
  250.         $text =~ s/^\xEF\xBB\xBF//;
  251.     }
  252.     else {
  253.         $text =~ s/^\x{FEFF}//;
  254.     }
  255.     $self->{first_chunk}++;
  256.     }
  257.     my $tag = $self->{tag};
  258.     if (!$tag && $text =~ /\S/) {
  259.     # Normal text means start of body
  260.         $self->eof;
  261.     return;
  262.     }
  263.     return if $tag ne 'title';
  264.     $self->{'text'} .= $text;
  265. }
  266.  
  267. BEGIN {
  268.     *utf8_mode = sub { 1 } unless HTML::Entities::UNICODE_SUPPORT;;
  269. }
  270.  
  271. 1;
  272.  
  273. __END__
  274.  
  275. =back
  276.  
  277. =head1 EXAMPLE
  278.  
  279.  $h = HTTP::Headers->new;
  280.  $p = HTML::HeadParser->new($h);
  281.  $p->parse(<<EOT);
  282.  <title>Stupid example</title>
  283.  <base href="http://www.linpro.no/lwp/">
  284.  Normal text starts here.
  285.  EOT
  286.  undef $p;
  287.  print $h->title;   # should print "Stupid example"
  288.  
  289. =head1 SEE ALSO
  290.  
  291. L<HTML::Parser>, L<HTTP::Headers>
  292.  
  293. The C<HTTP::Headers> class is distributed as part of the
  294. I<libwww-perl> package.  If you don't have that distribution installed
  295. you need to provide the $header argument to the C<HTML::HeadParser>
  296. constructor with your own object that implements the documented
  297. protocol.
  298.  
  299. =head1 COPYRIGHT
  300.  
  301. Copyright 1996-2001 Gisle Aas. All rights reserved.
  302.  
  303. This library is free software; you can redistribute it and/or
  304. modify it under the same terms as Perl itself.
  305.  
  306. =cut
  307.  
  308.