nxhtml/nxhtml/html-chklnk/PerlLib/HTML/ParserTagEnd.pm

   1 package HTML::ParserTagEnd;
   2
   3 # Author address: <gisle@aas.no>
   4 ### Modified for <tag />, Lennart
   5
   6 use strict;
   7 use HTML::Entities ();
   8
   9 use vars qw($VERSION);
  10 $VERSION = "2.23";  # $Date: 1999/06/09 10:27:16 $
  11
  12
  13 sub new
  14 {
  15     my $class = shift;
  16     my $self = bless { '_buf'            => '',
  17                        '_strict_comment' => 0,
  18                      }, $class;
  19     $self;
  20 }
  21
  22
  23 # A little note about the observed Netscape behaviour:
  24 #
  25 # It parse <xmp> in the depreceated 'literal' mode, i.e. no tags are
  26 # recognized until a </xmp> is found.
  27 #
  28 # <listing> is parsed like <pre>, i.e. tags are recognized.  <listing>
  29 # are presentend in smaller font than <pre>
  30 #
  31 # Netscape does not parse this comment correctly (it terminates the comment
  32 # too early):
  33 #
  34 #    <! -- comment -- --> more comment -->
  35 #
  36 # Netscape ignores '<!--' and '-->' within the <SCRIPT> and <STYLE> tag.
  37 # This is used as a trick to make non-script-aware browsers ignore
  38 # the scripts.
  39
  40
  41 sub parse
  42 {
  43     my $self = shift;
  44     my $buf = \ $self->{'_buf'};
  45     unless (defined $_[0]) {
  46         # signals EOF (assume rest is plain text)
  47         $self->text($$buf) if length $$buf;
  48         $$buf = '';
  49         return $self;
  50     }
  51     $$buf .= $_[0];
  52     my $netscape_comment = !$self->{'_strict_comment'};
  53
  54     # Parse html text in $$buf.  The strategy is to remove complete
  55     # tokens from the beginning of $$buf until we can't deside whether
  56     # it is a token or not, or the $$buf is empty.
  57
  58   TOKEN:
  59     while (1) {
  60
  61         # First we try to pull off any plain text (anything before a "<" char)
  62         if ($$buf =~ s|^([^<]+)||) {
  63             if (length $$buf) {
  64                 $self->text($1);
  65             } else {
  66                 my $text = $1;
  67                 # At the end of the buffer, we should not parse white space
  68                 # but leave it for parsing on the next round.
  69                 if ($text =~ s|(\s+)$||) {
  70                     $$buf = $1;
  71                 # Same treatment for chopped up entites and words.
  72                 # We must wait until we have it all.
  73                 } elsif ($text =~ s|(\s*\S+)$||) {
  74                     $$buf = $1;
  75                 };
  76                 $self->text($text) if length $text;
  77                 last TOKEN;
  78             }
  79
  80         # Netscapes buggy comments are easy to handle
  81         } elsif ($netscape_comment && $$buf =~ m|^<!\s*--|) {
  82             if ($$buf =~ s|^<!\s*--(.*?)--\s*>||s) {
  83                 $self->comment($1);
  84             } else {
  85                 last TOKEN;  # must wait until we see the end of it
  86             }
  87
  88         # Then, markup declarations (usually either <!DOCTYPE...> or a comment)
  89         } elsif ($$buf =~ s|^(<!)||) {
  90             my $eaten = $1;
  91             my $text = '';
  92             my @com = ();  # keeps comments until we have seen the end
  93             # Eat text and beginning of comment
  94             while ($$buf =~ s|^(([^>]*?)--)||) {
  95                 $eaten .= $1;
  96                 $text .= $2;
  97                 # Look for end of comment
  98                 if ($$buf =~ s|^((.*?)--)||s) {
  99                     $eaten .= $1;
 100                     push(@com, $2);
 101                 } else {
 102                     # Need more data to get all comment text.
 103                     $$buf = $eaten . $$buf;
 104                     last TOKEN;
 105                 }
 106             }
 107             # Can we finish the tag
 108             if ($$buf =~ s|^([^>]*)>||) {
 109                 $text .= $1;
 110                 $self->declaration($text) if $text =~ /\S/;
 111                 # then tell about all the comments we found
 112                 for (@com) { $self->comment($_); }
 113             } else {
 114                 $$buf = $eaten . $$buf;  # must start with it all next time
 115                 last TOKEN;
 116             }
 117
 118         # Should we look for 'processing instructions' <? ...> ??
 119         #} elsif ($$buf =~ s|<\?||) {
 120             # ...
 121
 122         # Then, look for a end tag
 123         } elsif ($$buf =~ s|^</||) {
 124             # end tag
 125             if ($$buf =~ s|^([a-zA-Z][a-zA-Z0-9\.\-]*)(\s*>)||) {
 126                 $self->end(lc($1), "</$1$2");
 127             } elsif ($$buf =~ m|^[a-zA-Z]*[a-zA-Z0-9\.\-]*\s*$|) {
 128                 $$buf = "</" . $$buf;  # need more data to be sure
 129                 last TOKEN;
 130             } else {
 131                 # it is plain text after all
 132                 $self->text("</");
 133             }
 134
 135         # Then, finally we look for a start tag
 136         } elsif ($$buf =~ s|^(<([a-zA-Z]+)>)||) {
 137             # special case plain start tags for slight speed-up (2.5%)
 138             ### mod Lennart
 139             $self->start(lc($2), {}, 0, [], $1);
 140
 141         } elsif ($$buf =~ s|^<||) {
 142             # start tag
 143             my $eaten = '<';
 144
 145             # This first thing we must find is a tag name.  RFC1866 says:
 146             #   A name consists of a letter followed by letters,
 147             #   digits, periods, or hyphens. The length of a name is
 148             #   limited to 72 characters by the `NAMELEN' parameter in
 149             #   the SGML declaration for HTML, 9.5, "SGML Declaration
 150             #   for HTML".  In a start-tag, the element name must
 151             #   immediately follow the tag open delimiter `<'.
 152             if ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\.\-]*)\s*)||) {
 153                 $eaten .= $1;
 154                 my $tag = lc $2;
 155                 my %attr;
 156                 my @attrseq;
 157
 158                 # Then we would like to find some attributes
 159                 #
 160                 # Arrgh!! Since stupid Netscape violates RCF1866 by
 161                 # using "_" in attribute names (like "ADD_DATE") of
 162                 # their bookmarks.html, we allow this too.
 163                 while ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\.\-_]*)\s*)||) {
 164                     $eaten .= $1;
 165                     my $attr = lc $2;
 166                     my $val;
 167                     # The attribute might take an optional value (first we
 168                     # check for an unquoted value)
 169                     if ($$buf =~ s|(^=\s*([^\"\'>\s][^>\s]*)\s*)||) {
 170                         $eaten .= $1;
 171                         $val = $2;
 172                         HTML::Entities::decode($val);
 173                     # or quoted by " or '
 174                     } elsif ($$buf =~ s|(^=\s*([\"\'])(.*?)\2\s*)||s) {
 175                         $eaten .= $1;
 176                         $val = $3;
 177                         HTML::Entities::decode($val);
 178                     # truncated just after the '=' or inside the attribute
 179                     } elsif ($$buf =~ m|^(=\s*)$| or
 180                              $$buf =~ m|^(=\s*[\"\'].*)|s) {
 181                         $$buf = "$eaten$1";
 182                         last TOKEN;
 183                     } else {
 184                         # assume attribute with implicit value
 185                         $val = $attr;
 186                     }
 187                     $attr{$attr} = $val;
 188                     push(@attrseq, $attr);
 189                 }
 190
 191                 # At the end there should be a closing ">"
 192 ### Modified for <tag />, Lennart
 193                 if ($$buf =~ s|^/>||) {
 194                     $self->start($tag, \%attr, 1, \@attrseq, "$eaten>");
 195                 } elsif ($$buf =~ s|^>||) {
 196                 #if ($$buf =~ s|^>||) {
 197                     $self->start($tag, \%attr, 0, \@attrseq, "$eaten>");
 198                 } elsif (length $$buf) {
 199                     # Not a conforming start tag, regard it as normal text
 200                     $self->text($eaten);
 201                 } else {
 202                     $$buf = $eaten;  # need more data to know
 203                     last TOKEN;
 204                 }
 205
 206             } elsif (length $$buf) {
 207                 $self->text($eaten);
 208             } else {
 209                 $$buf = $eaten . $$buf;  # need more data to parse
 210                 last TOKEN;
 211             }
 212
 213         } else {
 214             #die if length($$buf);  # This should never happen
 215             last TOKEN;             # The buffer should be empty now
 216         }
 217     }
 218
 219     $self;
 220 }
 221
 222
 223 sub eof
 224 {
 225     shift->parse(undef);
 226 }
 227
 228
 229 sub parse_file
 230 {
 231     my($self, $file) = @_;
 232     no strict 'refs';  # so that a symbol ref as $file works
 233     local(*F);
 234     unless (ref($file) || $file =~ /^\*[\w:]+$/) {
 235         # Assume $file is a filename
 236         open(F, $file) || die "Can't open $file: $!";
 237         $file = \*F;
 238     }
 239     my $chunk = '';
 240     while(read($file, $chunk, 512)) {
 241         $self->parse($chunk);
 242     }
 243     close($file);
 244     $self->eof;
 245 }
 246
 247
 248 sub strict_comment
 249 {
 250     my $self = shift;
 251     my $old = $self->{'_strict_comment'};
 252     $self->{'_strict_comment'} = shift if @_;
 253     return $old;
 254 }
 255
 256
 257 sub netscape_buggy_comment  # legacy
 258 {
 259     my $self = shift;
 260     my $old = !$self->strict_comment;
 261     $self->strict_comment(!shift) if @_;
 262     return $old;
 263 }
 264
 265
 266 sub text
 267 {
 268     # my($self, $text) = @_;
 269 }
 270
 271 sub declaration
 272 {
 273     # my($self, $decl) = @_;
 274 }
 275
 276 sub comment
 277 {
 278     # my($self, $comment) = @_;
 279 }
 280
 281 sub start
 282 {
 283 die "hie";
 284     # my($self, $tag, $attr, $attrseq, $origtext) = @_;
 285     # $attr is reference to a HASH, $attrseq is reference to an ARRAY
 286 }
 287
 288 sub end
 289 {
 290     # my($self, $tag, $origtext) = @_;
 291 }
 292
 293 1;
 294
 295
 296 __END__
 297
 298
 299 =head1 NAME
 300
 301 HTML::Parser - SGML parser class
 302
 303 =head1 SYNOPSIS
 304
 305  require HTML::Parser;
 306  $p = HTML::Parser->new;  # should really a be subclass
 307  $p->parse($chunk1);
 308  $p->parse($chunk2);
 309  #...
 310  $p->eof;                 # signal end of document
 311
 312  # Parse directly from file
 313  $p->parse_file("foo.html");
 314  # or
 315  open(F, "foo.html") || die;
 316  $p->parse_file(\*F);
 317
 318 =head1 DESCRIPTION
 319
 320 The C<HTML::Parser> will tokenize an HTML document when the parse()
 321 method is called by invoking various callback methods.  The document to
 322 be parsed can be supplied in arbitrary chunks.
 323
 324 The external interface the an I<HTML::Parser> is:
 325
 326 =over 4
 327
 328 =item $p = HTML::Parser->new
 329
 330 The object constructor takes no arguments.
 331
 332 =item $p->parse( $string );
 333
 334 Parse the $string as an HTML document.  Can be called multiple times.
 335 The return value is a reference to the parser object.
 336
 337 =item $p->eof
 338
 339 Signals end of document.  Call eof() to flush any remaining buffered
 340 text.  The return value is a reference to the parser object.
 341
 342 =item $p->parse_file( $file );
 343
 344 This method can be called to parse text from a file.  The argument can
 345 be a filename or an already opened file handle. The return value from
 346 parse_file() is a reference to the parser object.
 347
 348 =item $p->strict_comment( [$bool] )
 349
 350 By default we parse comments similar to how the popular browsers (like
 351 Netscape and MSIE) do it.  This means that comments will always be
 352 terminated by the first occurrence of "-->".  This is not correct
 353 according to the "official" HTML standards.  The official behaviour
 354 can be enabled by calling the strict_comment() method with a TRUE
 355 argument.
 356
 357 The return value from strict_comment() is the old attribute value.
 358
 359 =back
 360
 361
 362
 363 In order to make the parser do anything interesting, you must make a
 364 subclass where you override one or more of the following methods as
 365 appropriate:
 366
 367 =over 4
 368
 369 =item $self->declaration($decl)
 370
 371 This method is called when a I<markup declaration> has been
 372 recognized.  For typical HTML documents, the only declaration you are
 373 likely to find is <!DOCTYPE ...>.  The initial "<!" and ending ">" is
 374 not part of the string passed as argument.  Comments are removed and
 375 entities will B<not> be expanded.
 376
 377 =item $self->start($tag, $attr, $attrseq, $origtext)
 378
 379 This method is called when a complete start tag has been recognized.
 380 The first argument is the tag name (in lower case) and the second
 381 argument is a reference to a hash that contain all attributes found
 382 within the start tag.  The attribute keys are converted to lower case.
 383 Entities found in the attribute values are already expanded.  The
 384 third argument is a reference to an array with the lower case
 385 attribute keys in the original order.  The fourth argument is the
 386 original HTML text.
 387
 388
 389 =item $self->end($tag, $origtext)
 390
 391 This method is called when an end tag has been recognized.  The
 392 first argument is the lower case tag name, the second the original
 393 HTML text of the tag.
 394
 395 =item $self->text($text)
 396
 397 This method is called when plain text in the document is recognized.
 398 The text is passed on unmodified and might contain multiple lines.
 399 Note that for efficiency reasons entities in the text are B<not>
 400 expanded.  You should call HTML::Entities::decode($text) before you
 401 process the text any further.
 402
 403 A sequence of text in the HTML document can be broken between several
 404 invocations of $self->text.  The parser will make sure that it does
 405 not break a word or a sequence of spaces between two invocations of
 406 $self->text().
 407
 408 =item $self->comment($comment)
 409
 410 This method is called as comments are recognized.  The leading and
 411 trailing "--" sequences have been stripped off the comment text.
 412
 413 =back
 414
 415 The default implementation of these methods do nothing, i.e., the
 416 tokens are just ignored.
 417
 418 There is really nothing in the basic parser that is HTML specific, so
 419 it is likely that the parser can parse other kinds of SGML documents.
 420 SGML has many obscure features (not implemented by this module) that
 421 prevent us from renaming this module as C<SGML::Parser>.
 422
 423 =head1 EFFICIENCY
 424
 425 The parser is fairly inefficient if the chunks passed to $p->parse()
 426 are too big.  The reason is probably that perl ends up with a lot of
 427 character copying when tokens are removed from the beginning of the
 428 strings.  A chunk size of about 256-512 bytes was optimal in a test I
 429 made with some real world HTML documents.  (The parser was about 3
 430 times slower with a chunk size of 20K).
 431
 432 =head1 SEE ALSO
 433
 434 L<HTML::Entities>, L<HTML::TokeParser>, L<HTML::Filter>,
 435 L<HTML::HeadParser>, L<HTML::LinkExtor>
 436
 437 L<HTML::TreeBuilder> (part of the I<HTML-Tree> distribution)
 438
 439 =head1 COPYRIGHT
 440
 441 Copyright 1996-1999 Gisle Aas. All rights reserved.
 442
 443 This library is free software; you can redistribute it and/or
 444 modify it under the same terms as Perl itself.
 445
 446 =cut
 447
 448