diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/HTML')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/Entities.pm | 500 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/Filter.pm | 112 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/Form.pm | 1551 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/HeadParser.pm | 301 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/LinkExtor.pm | 185 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/Parser.pm | 1240 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/PullParser.pm | 209 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/Tagset.pm | 471 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/HTML/TokeParser.pm | 369 |
9 files changed, 4938 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/HTML/Entities.pm b/Master/tlpkg/tlperl/lib/HTML/Entities.pm new file mode 100755 index 00000000000..38cd41e62b0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/Entities.pm @@ -0,0 +1,500 @@ +package HTML::Entities; + +=head1 NAME + +HTML::Entities - Encode or decode strings with HTML entities + +=head1 SYNOPSIS + + use HTML::Entities; + + $a = "Våre norske tegn bør æres"; + decode_entities($a); + encode_entities($a, "\200-\377"); + +For example, this: + + $input = "vis-à-vis Beyoncé's naïve\npapier-mâché résumé"; + print encode_entities($input), "\n" + +Prints this out: + + vis-à-vis Beyoncé's naïve + papier-mâché résumé + +=head1 DESCRIPTION + +This module deals with encoding and decoding of strings with HTML +character entities. The module provides the following functions: + +=over 4 + +=item decode_entities( $string, ... ) + +This routine replaces HTML entities found in the $string with the +corresponding Unicode character. Under perl 5.6 and earlier only +characters in the Latin-1 range are replaced. Unrecognized +entities are left alone. + +If multiple strings are provided as argument they are each decoded +separately and the same number of strings are returned. + +If called in void context the arguments are decoded in-place. + +This routine is exported by default. + +=item _decode_entities( $string, \%entity2char ) + +=item _decode_entities( $string, \%entity2char, $expand_prefix ) + +This will in-place replace HTML entities in $string. The %entity2char +hash must be provided. Named entities not found in the %entity2char +hash are left alone. Numeric entities are expanded unless their value +overflow. + +The keys in %entity2char are the entity names to be expanded and their +values are what they should expand into. The values do not have to be +single character strings. If a key has ";" as suffix, +then occurrences in $string are only expanded if properly terminated +with ";". Entities without ";" will be expanded regardless of how +they are terminated for compatibility with how common browsers treat +entities in the Latin-1 range. + +If $expand_prefix is TRUE then entities without trailing ";" in +%entity2char will even be expanded as a prefix of a longer +unrecognized name. The longest matching name in %entity2char will be +used. This is mainly present for compatibility with an MSIE +misfeature. + + $string = "foo bar"; + _decode_entities($string, { nb => "@", nbsp => "\xA0" }, 1); + print $string; # will print "foo bar" + +This routine is exported by default. + +=item encode_entities( $string ) + +=item encode_entities( $string, $unsafe_chars ) + +This routine replaces unsafe characters in $string with their entity +representation. A second argument can be given to specify which characters to +consider unsafe. The unsafe characters is specified using the regular +expression character class syntax (what you find within brackets in regular +expressions). + +The default set of characters to encode are control chars, high-bit chars, and +the C<< < >>, C<< & >>, C<< > >>, C<< ' >> and C<< " >> characters. But this, +for example, would encode I<just> the C<< < >>, C<< & >>, C<< > >>, and C<< " +>> characters: + + $encoded = encode_entities($input, '<>&"'); + +and this would only encode non-plain ascii: + + $encoded = encode_entities($input, '^\n\x20-\x25\x27-\x7e'); + +This routine is exported by default. + +=item encode_entities_numeric( $string ) + +=item encode_entities_numeric( $string, $unsafe_chars ) + +This routine works just like encode_entities, except that the replacement +entities are always C<&#xI<hexnum>;> and never C<&I<entname>;>. For +example, C<encode_entities("r\xF4le")> returns "rôle", but +C<encode_entities_numeric("r\xF4le")> returns "rôle". + +This routine is I<not> exported by default. But you can always +export it with C<use HTML::Entities qw(encode_entities_numeric);> +or even C<use HTML::Entities qw(:DEFAULT encode_entities_numeric);> + +=back + +All these routines modify the string passed as the first argument, if +called in a void context. In scalar and array contexts, the encoded or +decoded string is returned (without changing the input string). + +If you prefer not to import these routines into your namespace, you can +call them as: + + use HTML::Entities (); + $decoded = HTML::Entities::decode($a); + $encoded = HTML::Entities::encode($a); + $encoded = HTML::Entities::encode_numeric($a); + +The module can also export the %char2entity and the %entity2char +hashes, which contain the mapping from all characters to the +corresponding entities (and vice versa, respectively). + +=head1 COPYRIGHT + +Copyright 1995-2006 Gisle Aas. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); +use vars qw(%entity2char %char2entity); + +require 5.004; +require Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw(encode_entities decode_entities _decode_entities); +@EXPORT_OK = qw(%entity2char %char2entity encode_entities_numeric); + +$VERSION = "3.64"; +sub Version { $VERSION; } + +require HTML::Parser; # for fast XS implemented decode_entities + + +%entity2char = ( + # Some normal chars that have special meaning in SGML context + amp => '&', # ampersand +'gt' => '>', # greater than +'lt' => '<', # less than + quot => '"', # double quote + apos => "'", # single quote + + # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML + AElig => chr(198), # capital AE diphthong (ligature) + Aacute => chr(193), # capital A, acute accent + Acirc => chr(194), # capital A, circumflex accent + Agrave => chr(192), # capital A, grave accent + Aring => chr(197), # capital A, ring + Atilde => chr(195), # capital A, tilde + Auml => chr(196), # capital A, dieresis or umlaut mark + Ccedil => chr(199), # capital C, cedilla + ETH => chr(208), # capital Eth, Icelandic + Eacute => chr(201), # capital E, acute accent + Ecirc => chr(202), # capital E, circumflex accent + Egrave => chr(200), # capital E, grave accent + Euml => chr(203), # capital E, dieresis or umlaut mark + Iacute => chr(205), # capital I, acute accent + Icirc => chr(206), # capital I, circumflex accent + Igrave => chr(204), # capital I, grave accent + Iuml => chr(207), # capital I, dieresis or umlaut mark + Ntilde => chr(209), # capital N, tilde + Oacute => chr(211), # capital O, acute accent + Ocirc => chr(212), # capital O, circumflex accent + Ograve => chr(210), # capital O, grave accent + Oslash => chr(216), # capital O, slash + Otilde => chr(213), # capital O, tilde + Ouml => chr(214), # capital O, dieresis or umlaut mark + THORN => chr(222), # capital THORN, Icelandic + Uacute => chr(218), # capital U, acute accent + Ucirc => chr(219), # capital U, circumflex accent + Ugrave => chr(217), # capital U, grave accent + Uuml => chr(220), # capital U, dieresis or umlaut mark + Yacute => chr(221), # capital Y, acute accent + aacute => chr(225), # small a, acute accent + acirc => chr(226), # small a, circumflex accent + aelig => chr(230), # small ae diphthong (ligature) + agrave => chr(224), # small a, grave accent + aring => chr(229), # small a, ring + atilde => chr(227), # small a, tilde + auml => chr(228), # small a, dieresis or umlaut mark + ccedil => chr(231), # small c, cedilla + eacute => chr(233), # small e, acute accent + ecirc => chr(234), # small e, circumflex accent + egrave => chr(232), # small e, grave accent + eth => chr(240), # small eth, Icelandic + euml => chr(235), # small e, dieresis or umlaut mark + iacute => chr(237), # small i, acute accent + icirc => chr(238), # small i, circumflex accent + igrave => chr(236), # small i, grave accent + iuml => chr(239), # small i, dieresis or umlaut mark + ntilde => chr(241), # small n, tilde + oacute => chr(243), # small o, acute accent + ocirc => chr(244), # small o, circumflex accent + ograve => chr(242), # small o, grave accent + oslash => chr(248), # small o, slash + otilde => chr(245), # small o, tilde + ouml => chr(246), # small o, dieresis or umlaut mark + szlig => chr(223), # small sharp s, German (sz ligature) + thorn => chr(254), # small thorn, Icelandic + uacute => chr(250), # small u, acute accent + ucirc => chr(251), # small u, circumflex accent + ugrave => chr(249), # small u, grave accent + uuml => chr(252), # small u, dieresis or umlaut mark + yacute => chr(253), # small y, acute accent + yuml => chr(255), # small y, dieresis or umlaut mark + + # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) + copy => chr(169), # copyright sign + reg => chr(174), # registered sign + nbsp => chr(160), # non breaking space + + # Additional ISO-8859/1 entities listed in rfc1866 (section 14) + iexcl => chr(161), + cent => chr(162), + pound => chr(163), + curren => chr(164), + yen => chr(165), + brvbar => chr(166), + sect => chr(167), + uml => chr(168), + ordf => chr(170), + laquo => chr(171), +'not' => chr(172), # not is a keyword in perl + shy => chr(173), + macr => chr(175), + deg => chr(176), + plusmn => chr(177), + sup1 => chr(185), + sup2 => chr(178), + sup3 => chr(179), + acute => chr(180), + micro => chr(181), + para => chr(182), + middot => chr(183), + cedil => chr(184), + ordm => chr(186), + raquo => chr(187), + frac14 => chr(188), + frac12 => chr(189), + frac34 => chr(190), + iquest => chr(191), +'times' => chr(215), # times is a keyword in perl + divide => chr(247), + + ( $] > 5.007 ? ( + 'OElig;' => chr(338), + 'oelig;' => chr(339), + 'Scaron;' => chr(352), + 'scaron;' => chr(353), + 'Yuml;' => chr(376), + 'fnof;' => chr(402), + 'circ;' => chr(710), + 'tilde;' => chr(732), + 'Alpha;' => chr(913), + 'Beta;' => chr(914), + 'Gamma;' => chr(915), + 'Delta;' => chr(916), + 'Epsilon;' => chr(917), + 'Zeta;' => chr(918), + 'Eta;' => chr(919), + 'Theta;' => chr(920), + 'Iota;' => chr(921), + 'Kappa;' => chr(922), + 'Lambda;' => chr(923), + 'Mu;' => chr(924), + 'Nu;' => chr(925), + 'Xi;' => chr(926), + 'Omicron;' => chr(927), + 'Pi;' => chr(928), + 'Rho;' => chr(929), + 'Sigma;' => chr(931), + 'Tau;' => chr(932), + 'Upsilon;' => chr(933), + 'Phi;' => chr(934), + 'Chi;' => chr(935), + 'Psi;' => chr(936), + 'Omega;' => chr(937), + 'alpha;' => chr(945), + 'beta;' => chr(946), + 'gamma;' => chr(947), + 'delta;' => chr(948), + 'epsilon;' => chr(949), + 'zeta;' => chr(950), + 'eta;' => chr(951), + 'theta;' => chr(952), + 'iota;' => chr(953), + 'kappa;' => chr(954), + 'lambda;' => chr(955), + 'mu;' => chr(956), + 'nu;' => chr(957), + 'xi;' => chr(958), + 'omicron;' => chr(959), + 'pi;' => chr(960), + 'rho;' => chr(961), + 'sigmaf;' => chr(962), + 'sigma;' => chr(963), + 'tau;' => chr(964), + 'upsilon;' => chr(965), + 'phi;' => chr(966), + 'chi;' => chr(967), + 'psi;' => chr(968), + 'omega;' => chr(969), + 'thetasym;' => chr(977), + 'upsih;' => chr(978), + 'piv;' => chr(982), + 'ensp;' => chr(8194), + 'emsp;' => chr(8195), + 'thinsp;' => chr(8201), + 'zwnj;' => chr(8204), + 'zwj;' => chr(8205), + 'lrm;' => chr(8206), + 'rlm;' => chr(8207), + 'ndash;' => chr(8211), + 'mdash;' => chr(8212), + 'lsquo;' => chr(8216), + 'rsquo;' => chr(8217), + 'sbquo;' => chr(8218), + 'ldquo;' => chr(8220), + 'rdquo;' => chr(8221), + 'bdquo;' => chr(8222), + 'dagger;' => chr(8224), + 'Dagger;' => chr(8225), + 'bull;' => chr(8226), + 'hellip;' => chr(8230), + 'permil;' => chr(8240), + 'prime;' => chr(8242), + 'Prime;' => chr(8243), + 'lsaquo;' => chr(8249), + 'rsaquo;' => chr(8250), + 'oline;' => chr(8254), + 'frasl;' => chr(8260), + 'euro;' => chr(8364), + 'image;' => chr(8465), + 'weierp;' => chr(8472), + 'real;' => chr(8476), + 'trade;' => chr(8482), + 'alefsym;' => chr(8501), + 'larr;' => chr(8592), + 'uarr;' => chr(8593), + 'rarr;' => chr(8594), + 'darr;' => chr(8595), + 'harr;' => chr(8596), + 'crarr;' => chr(8629), + 'lArr;' => chr(8656), + 'uArr;' => chr(8657), + 'rArr;' => chr(8658), + 'dArr;' => chr(8659), + 'hArr;' => chr(8660), + 'forall;' => chr(8704), + 'part;' => chr(8706), + 'exist;' => chr(8707), + 'empty;' => chr(8709), + 'nabla;' => chr(8711), + 'isin;' => chr(8712), + 'notin;' => chr(8713), + 'ni;' => chr(8715), + 'prod;' => chr(8719), + 'sum;' => chr(8721), + 'minus;' => chr(8722), + 'lowast;' => chr(8727), + 'radic;' => chr(8730), + 'prop;' => chr(8733), + 'infin;' => chr(8734), + 'ang;' => chr(8736), + 'and;' => chr(8743), + 'or;' => chr(8744), + 'cap;' => chr(8745), + 'cup;' => chr(8746), + 'int;' => chr(8747), + 'there4;' => chr(8756), + 'sim;' => chr(8764), + 'cong;' => chr(8773), + 'asymp;' => chr(8776), + 'ne;' => chr(8800), + 'equiv;' => chr(8801), + 'le;' => chr(8804), + 'ge;' => chr(8805), + 'sub;' => chr(8834), + 'sup;' => chr(8835), + 'nsub;' => chr(8836), + 'sube;' => chr(8838), + 'supe;' => chr(8839), + 'oplus;' => chr(8853), + 'otimes;' => chr(8855), + 'perp;' => chr(8869), + 'sdot;' => chr(8901), + 'lceil;' => chr(8968), + 'rceil;' => chr(8969), + 'lfloor;' => chr(8970), + 'rfloor;' => chr(8971), + 'lang;' => chr(9001), + 'rang;' => chr(9002), + 'loz;' => chr(9674), + 'spades;' => chr(9824), + 'clubs;' => chr(9827), + 'hearts;' => chr(9829), + 'diams;' => chr(9830), + ) : ()) +); + + +# Make the opposite mapping +while (my($entity, $char) = each(%entity2char)) { + $entity =~ s/;\z//; + $char2entity{$char} = "&$entity;"; +} +delete $char2entity{"'"}; # only one-way decoding + +# Fill in missing entities +for (0 .. 255) { + next if exists $char2entity{chr($_)}; + $char2entity{chr($_)} = "&#$_;"; +} + +my %subst; # compiled encoding regexps + +sub decode_entities_old +{ + my $array; + if (defined wantarray) { + $array = [@_]; # copy + } else { + $array = \@_; # modify in-place + } + my $c; + for (@$array) { + s/(&\#(\d+);?)/$2 < 256 ? chr($2) : $1/eg; + s/(&\#[xX]([0-9a-fA-F]+);?)/$c = hex($2); $c < 256 ? chr($c) : $1/eg; + s/(&(\w+);?)/$entity2char{$2} || $1/eg; + } + wantarray ? @$array : $array->[0]; +} + +sub encode_entities +{ + return undef unless defined $_[0]; + my $ref; + if (defined wantarray) { + my $x = $_[0]; + $ref = \$x; # copy + } else { + $ref = \$_[0]; # modify in-place + } + if (defined $_[1] and length $_[1]) { + unless (exists $subst{$_[1]}) { + # Because we can't compile regex we fake it with a cached sub + my $chars = $_[1]; + $chars =~ s,(?<!\\)([]/]),\\$1,g; + $chars =~ s,(?<!\\)\\\z,\\\\,; + my $code = "sub {\$_[0] =~ s/([$chars])/\$char2entity{\$1} || num_entity(\$1)/ge; }"; + $subst{$_[1]} = eval $code; + die( $@ . " while trying to turn range: \"$_[1]\"\n " + . "into code: $code\n " + ) if $@; + } + &{$subst{$_[1]}}($$ref); + } else { + # Encode control chars, high bit chars and '<', '&', '>', ''' and '"' + $$ref =~ s/([^\n\r\t !\#\$%\(-;=?-~])/$char2entity{$1} || num_entity($1)/ge; + } + $$ref; +} + +sub encode_entities_numeric { + local %char2entity; + return &encode_entities; # a goto &encode_entities wouldn't work +} + + +sub num_entity { + sprintf "&#x%X;", ord($_[0]); +} + +# Set up aliases +*encode = \&encode_entities; +*encode_numeric = \&encode_entities_numeric; +*encode_numerically = \&encode_entities_numeric; +*decode = \&decode_entities; + +1; diff --git a/Master/tlpkg/tlperl/lib/HTML/Filter.pm b/Master/tlpkg/tlperl/lib/HTML/Filter.pm new file mode 100755 index 00000000000..c5aa16e6dd8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/Filter.pm @@ -0,0 +1,112 @@ +package HTML::Filter; + +use strict; +use vars qw(@ISA $VERSION); + +require HTML::Parser; +@ISA=qw(HTML::Parser); + +$VERSION = "3.57"; + +sub declaration { $_[0]->output("<!$_[1]>") } +sub process { $_[0]->output($_[2]) } +sub comment { $_[0]->output("<!--$_[1]-->") } +sub start { $_[0]->output($_[4]) } +sub end { $_[0]->output($_[2]) } +sub text { $_[0]->output($_[1]) } + +sub output { print $_[1] } + +1; + +__END__ + +=head1 NAME + +HTML::Filter - Filter HTML text through the parser + +=head1 NOTE + +B<This module is deprecated.> The C<HTML::Parser> now provides the +functionally of C<HTML::Filter> much more efficiently with the the +C<default> handler. + +=head1 SYNOPSIS + + require HTML::Filter; + $p = HTML::Filter->new->parse_file("index.html"); + +=head1 DESCRIPTION + +C<HTML::Filter> is an HTML parser that by default prints the +original text of each HTML element (a slow version of cat(1) basically). +The callback methods may be overridden to modify the filtering for some +HTML elements and you can override output() method which is called to +print the HTML text. + +C<HTML::Filter> is a subclass of C<HTML::Parser>. This means that +the document should be given to the parser by calling the $p->parse() +or $p->parse_file() methods. + +=head1 EXAMPLES + +The first example is a filter that will remove all comments from an +HTML file. This is achieved by simply overriding the comment method +to do nothing. + + package CommentStripper; + require HTML::Filter; + @ISA=qw(HTML::Filter); + sub comment { } # ignore comments + +The second example shows a filter that will remove any E<lt>TABLE>s +found in the HTML file. We specialize the start() and end() methods +to count table tags and then make output not happen when inside a +table. + + package TableStripper; + require HTML::Filter; + @ISA=qw(HTML::Filter); + sub start + { + my $self = shift; + $self->{table_seen}++ if $_[0] eq "table"; + $self->SUPER::start(@_); + } + + sub end + { + my $self = shift; + $self->SUPER::end(@_); + $self->{table_seen}-- if $_[0] eq "table"; + } + + sub output + { + my $self = shift; + unless ($self->{table_seen}) { + $self->SUPER::output(@_); + } + } + +If you want to collect the parsed text internally you might want to do +something like this: + + package FilterIntoString; + require HTML::Filter; + @ISA=qw(HTML::Filter); + sub output { push(@{$_[0]->{fhtml}}, $_[1]) } + sub filtered_html { join("", @{$_[0]->{fhtml}}) } + +=head1 SEE ALSO + +L<HTML::Parser> + +=head1 COPYRIGHT + +Copyright 1997-1999 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/HTML/Form.pm b/Master/tlpkg/tlperl/lib/HTML/Form.pm new file mode 100755 index 00000000000..bbbd7771716 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/Form.pm @@ -0,0 +1,1551 @@ +package HTML::Form; + +use strict; +use URI; +use Carp (); + +use vars qw($VERSION $Encode_available); +$VERSION = "5.829"; + +eval { require Encode }; +$Encode_available = !$@; + +my %form_tags = map {$_ => 1} qw(input textarea button select option); + +my %type2class = ( + text => "TextInput", + password => "TextInput", + hidden => "TextInput", + textarea => "TextInput", + + "reset" => "IgnoreInput", + + radio => "ListInput", + checkbox => "ListInput", + option => "ListInput", + + button => "SubmitInput", + submit => "SubmitInput", + image => "ImageInput", + file => "FileInput", + + keygen => "KeygenInput", +); + +=head1 NAME + +HTML::Form - Class that represents an HTML form element + +=head1 SYNOPSIS + + use HTML::Form; + $form = HTML::Form->parse($html, $base_uri); + $form->value(query => "Perl"); + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $response = $ua->request($form->click); + +=head1 DESCRIPTION + +Objects of the C<HTML::Form> class represents a single HTML +C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a +sequence of inputs that usually have names, and which can take on +various values. The state of a form can be tweaked and it can then be +asked to provide C<HTTP::Request> objects that can be passed to the +request() method of C<LWP::UserAgent>. + +The following methods are available: + +=over 4 + +=item @forms = HTML::Form->parse( $html_document, $base_uri ) + +=item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt ) + +=item @forms = HTML::Form->parse( $response, %opt ) + +The parse() class method will parse an HTML document and build up +C<HTML::Form> objects for each <form> element found. If called in scalar +context only returns the first <form>. Returns an empty list if there +are no forms to be found. + +The required arguments is the HTML document to parse ($html_document) and the +URI used to retrieve the document ($base_uri). The base URI is needed to resolve +relative action URIs. The provided HTML document should be a Unicode string +(or US-ASCII). + +By default HTML::Form assumes that the original document was UTF-8 encoded and +thus encode forms that don't specify an explict I<accept-charset> as UTF-8. +The charset assumed can be overridden by providing the C<charset> option to +parse(). It's a good idea to be explict about this parameter as well, thus +the recommended simplest invocation becomes: + + my @forms = HTML::Form->parse( + Encode::decode($encoding, $html_document_bytes), + base => $base_uri, + charset => $encoding, + ); + +If the document was retrieved with LWP then the response object provide methods +to obtain a proper value for C<base> and C<charset>: + + my $ua = LWP::UserAgent->new; + my $response = $ua->get("http://www.example.com/form.html"); + my @forms = HTML::Form->parse($response->decoded_content, + base => $response->base, + charset => $response->content_charset, + ); + +In fact, the parse() method can parse from an C<HTTP::Response> object +directly, so the example above can be more conveniently written as: + + my $ua = LWP::UserAgent->new; + my $response = $ua->get("http://www.example.com/form.html"); + my @forms = HTML::Form->parse($response); + +Note that any object that implements a decoded_content(), base() and +content_charset() method with similar behaviour as C<HTTP::Response> will do. + +Additional options might be passed in to control how the parse method +behaves. The following are all the options currently recognized: + +=over + +=item C<< base => $uri >> + +This is the URI used to retrive the original document. This option is not optional ;-) + +=item C<< charset => $str >> + +Specify what charset the original document was encoded in. This is used as +the default for accept_charset. If not provided this defaults to "UTF-8". + +=item C<< verbose => $bool >> + +Warn (print messages to STDERR) about any bad HTML form constructs found. +You can trap these with $SIG{__WARN__}. + +=item C<< strict => $bool >> + +Initialize any form objects with the given strict attribute. + +=back + +=cut + +sub parse +{ + my $class = shift; + my $html = shift; + unshift(@_, "base") if @_ == 1; + my %opt = @_; + + require HTML::TokeParser; + my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html); + die "Failed to create HTML::TokeParser object" unless $p; + + my $base_uri = delete $opt{base}; + my $charset = delete $opt{charset}; + my $strict = delete $opt{strict}; + my $verbose = delete $opt{verbose}; + + if ($^W) { + Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt; + } + + unless (defined $base_uri) { + if (ref($html)) { + $base_uri = $html->base; + } + else { + Carp::croak("HTML::Form::parse: No \$base_uri provided"); + } + } + unless (defined $charset) { + if (ref($html) and $html->can("content_charset")) { + $charset = $html->content_charset; + } + unless ($charset) { + $charset = "UTF-8"; + } + } + + my @forms; + my $f; # current form + + my %openselect; # index to the open instance of a select + + while (my $t = $p->get_tag) { + my($tag,$attr) = @$t; + if ($tag eq "form") { + my $action = delete $attr->{'action'}; + $action = "" unless defined $action; + $action = URI->new_abs($action, $base_uri); + $f = $class->new($attr->{'method'}, + $action, + $attr->{'enctype'}); + $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'}; + $f->{default_charset} = $charset; + $f->{attr} = $attr; + $f->strict(1) if $strict; + %openselect = (); + push(@forms, $f); + my(%labels, $current_label); + while (my $t = $p->get_tag) { + my($tag, $attr) = @$t; + last if $tag eq "/form"; + + # if we are inside a label tag, then keep + # appending any text to the current label + if(defined $current_label) { + $current_label = join " ", + grep { defined and length } + $current_label, + $p->get_phrase; + } + + if ($tag eq "input") { + $attr->{value_name} = + exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} : + defined $current_label ? $current_label : + $p->get_phrase; + } + + if ($tag eq "label") { + $current_label = $p->get_phrase; + $labels{ $attr->{for} } = $current_label + if exists $attr->{for}; + } + elsif ($tag eq "/label") { + $current_label = undef; + } + elsif ($tag eq "input") { + my $type = delete $attr->{type} || "text"; + $f->push_input($type, $attr, $verbose); + } + elsif ($tag eq "button") { + my $type = delete $attr->{type} || "submit"; + $f->push_input($type, $attr, $verbose); + } + elsif ($tag eq "textarea") { + $attr->{textarea_value} = $attr->{value} + if exists $attr->{value}; + my $text = $p->get_text("/textarea"); + $attr->{value} = $text; + $f->push_input("textarea", $attr, $verbose); + } + elsif ($tag eq "select") { + # rename attributes reserved to come for the option tag + for ("value", "value_name") { + $attr->{"select_$_"} = delete $attr->{$_} + if exists $attr->{$_}; + } + # count this new select option separately + my $name = $attr->{name}; + $name = "" unless defined $name; + $openselect{$name}++; + + while ($t = $p->get_tag) { + my $tag = shift @$t; + last if $tag eq "/select"; + next if $tag =~ m,/?optgroup,; + next if $tag eq "/option"; + if ($tag eq "option") { + my %a = %{$t->[0]}; + # rename keys so they don't clash with %attr + for (keys %a) { + next if $_ eq "value"; + $a{"option_$_"} = delete $a{$_}; + } + while (my($k,$v) = each %$attr) { + $a{$k} = $v; + } + $a{value_name} = $p->get_trimmed_text; + $a{value} = delete $a{value_name} + unless defined $a{value}; + $a{idx} = $openselect{$name}; + $f->push_input("option", \%a, $verbose); + } + else { + warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose; + if ($tag eq "/form" || + $tag eq "input" || + $tag eq "textarea" || + $tag eq "select" || + $tag eq "keygen") + { + # MSIE implictly terminate the <select> here, so we + # try to do the same. Actually the MSIE behaviour + # appears really strange: <input> and <textarea> + # do implictly close, but not <select>, <keygen> or + # </form>. + my $type = ($tag =~ s,^/,,) ? "E" : "S"; + $p->unget_token([$type, $tag, @$t]); + last; + } + } + } + } + elsif ($tag eq "keygen") { + $f->push_input("keygen", $attr, $verbose); + } + } + } + elsif ($form_tags{$tag}) { + warn("<$tag> outside <form> in $base_uri\n") if $verbose; + } + } + for (@forms) { + $_->fixup; + } + + wantarray ? @forms : $forms[0]; +} + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->{method} = uc(shift || "GET"); + $self->{action} = shift || Carp::croak("No action defined"); + $self->{enctype} = lc(shift || "application/x-www-form-urlencoded"); + $self->{accept_charset} = "UNKNOWN"; + $self->{default_charset} = "UTF-8"; + $self->{inputs} = [@_]; + $self; +} + + +sub push_input +{ + my($self, $type, $attr, $verbose) = @_; + $type = lc $type; + my $class = $type2class{$type}; + unless ($class) { + Carp::carp("Unknown input type '$type'") if $verbose; + $class = "TextInput"; + } + $class = "HTML::Form::$class"; + my @extra; + push(@extra, readonly => 1) if $type eq "hidden"; + push(@extra, strict => 1) if $self->{strict}; + if ($type eq "file" && exists $attr->{value}) { + # it's not safe to trust the value set by the server + # the user always need to explictly set the names of files to upload + $attr->{orig_value} = delete $attr->{value}; + } + delete $attr->{type}; # don't confuse the type argument + my $input = $class->new(type => $type, %$attr, @extra); + $input->add_to_form($self); +} + + +=item $method = $form->method + +=item $form->method( $new_method ) + +This method is gets/sets the I<method> name used for the +C<HTTP::Request> generated. It is a string like "GET" or "POST". + +=item $action = $form->action + +=item $form->action( $new_action ) + +This method gets/sets the URI which we want to apply the request +I<method> to. + +=item $enctype = $form->enctype + +=item $form->enctype( $new_enctype ) + +This method gets/sets the encoding type for the form data. It is a +string like "application/x-www-form-urlencoded" or "multipart/form-data". + +=item $accept = $form->accept_charset + +=item $form->accept_charset( $new_accept ) + +This method gets/sets the list of charset encodings that the server processing +the form accepts. Current implementation supports only one-element lists. +Default value is "UNKNOWN" which we interpret as a request to use document +charset as specified by the 'charset' parameter of the parse() method. To +encode character strings you should have modern perl with Encode module. On +older perls the setting of this attribute has no effect. + +=cut + +BEGIN { + # Set up some accesor + for (qw(method action enctype accept_charset)) { + my $m = $_; + no strict 'refs'; + *{$m} = sub { + my $self = shift; + my $old = $self->{$m}; + $self->{$m} = shift if @_; + $old; + }; + } + *uri = \&action; # alias +} + +=item $value = $form->attr( $name ) + +=item $form->attr( $name, $new_value ) + +This method give access to the original HTML attributes of the <form> tag. +The $name should always be passed in lower case. + +Example: + + @f = HTML::Form->parse( $html, $foo ); + @f = grep $_->attr("id") eq "foo", @f; + die "No form named 'foo' found" unless @f; + $foo = shift @f; + +=cut + +sub attr { + my $self = shift; + my $name = shift; + return undef unless defined $name; + + my $old = $self->{attr}{$name}; + $self->{attr}{$name} = shift if @_; + return $old; +} + +=item $bool = $form->strict + +=item $form->strict( $bool ) + +Gets/sets the strict attribute of a form. If the strict is turned on +the methods that change values of the form will croak if you try to +set illegal values or modify readonly fields. The default is not to be strict. + +=cut + +sub strict { + my $self = shift; + my $old = $self->{strict}; + if (@_) { + $self->{strict} = shift; + for my $input (@{$self->{inputs}}) { + $input->strict($self->{strict}); + } + } + return $old; +} + + +=item @inputs = $form->inputs + +This method returns the list of inputs in the form. If called in +scalar context it returns the number of inputs contained in the form. +See L</INPUTS> for what methods are available for the input objects +returned. + +=cut + +sub inputs +{ + my $self = shift; + @{$self->{'inputs'}}; +} + + +=item $input = $form->find_input( $selector ) + +=item $input = $form->find_input( $selector, $type ) + +=item $input = $form->find_input( $selector, $type, $index ) + +This method is used to locate specific inputs within the form. All +inputs that match the arguments given are returned. In scalar context +only the first is returned, or C<undef> if none match. + +If $selector is specified, then the input's name, id, class attribute must +match. A selector prefixed with '#' must match the id attribute of the input. +A selector prefixed with '.' matches the class attribute. A selector prefixed +with '^' or with no prefix matches the name attribute. + +If $type is specified, then the input must have the specified type. +The following type names are used: "text", "password", "hidden", +"textarea", "file", "image", "submit", "radio", "checkbox" and "option". + +The $index is the sequence number of the input matched where 1 is the +first. If combined with $name and/or $type then it select the I<n>th +input with the given name and/or type. + +=cut + +sub find_input +{ + my($self, $name, $type, $no) = @_; + if (wantarray) { + my @res; + my $c; + for (@{$self->{'inputs'}}) { + next if defined($name) && !$_->selected($name); + next if $type && $type ne $_->{type}; + $c++; + next if $no && $no != $c; + push(@res, $_); + } + return @res; + + } + else { + $no ||= 1; + for (@{$self->{'inputs'}}) { + next if defined($name) && !$_->selected($name); + next if $type && $type ne $_->{type}; + next if --$no; + return $_; + } + return undef; + } +} + +sub fixup +{ + my $self = shift; + for (@{$self->{'inputs'}}) { + $_->fixup; + } +} + + +=item $value = $form->value( $selector ) + +=item $form->value( $selector, $new_value ) + +The value() method can be used to get/set the value of some input. If +strict is enabled and no input has the indicated name, then this method will croak. + +If multiple inputs have the same name, only the first one will be +affected. + +The call: + + $form->value('foo') + +is basically a short-hand for: + + $form->find_input('foo')->value; + +=cut + +sub value +{ + my $self = shift; + my $key = shift; + my $input = $self->find_input($key); + unless ($input) { + Carp::croak("No such field '$key'") if $self->{strict}; + return undef unless @_; + $input = $self->push_input("text", { name => $key, value => "" }); + } + local $Carp::CarpLevel = 1; + $input->value(@_); +} + +=item @names = $form->param + +=item @values = $form->param( $name ) + +=item $form->param( $name, $value, ... ) + +=item $form->param( $name, \@values ) + +Alternative interface to examining and setting the values of the form. + +If called without arguments then it returns the names of all the +inputs in the form. The names will not repeat even if multiple inputs +have the same name. In scalar context the number of different names +is returned. + +If called with a single argument then it returns the value or values +of inputs with the given name. If called in scalar context only the +first value is returned. If no input exists with the given name, then +C<undef> is returned. + +If called with 2 or more arguments then it will set values of the +named inputs. This form will croak if no inputs have the given name +or if any of the values provided does not fit. Values can also be +provided as a reference to an array. This form will allow unsetting +all values with the given name as well. + +This interface resembles that of the param() function of the CGI +module. + +=cut + +sub param { + my $self = shift; + if (@_) { + my $name = shift; + my @inputs; + for ($self->inputs) { + my $n = $_->name; + next if !defined($n) || $n ne $name; + push(@inputs, $_); + } + + if (@_) { + # set + die "No '$name' parameter exists" unless @inputs; + my @v = @_; + @v = @{$v[0]} if @v == 1 && ref($v[0]); + while (@v) { + my $v = shift @v; + my $err; + for my $i (0 .. @inputs-1) { + eval { + $inputs[$i]->value($v); + }; + unless ($@) { + undef($err); + splice(@inputs, $i, 1); + last; + } + $err ||= $@; + } + die $err if $err; + } + + # the rest of the input should be cleared + for (@inputs) { + $_->value(undef); + } + } + else { + # get + my @v; + for (@inputs) { + if (defined(my $v = $_->value)) { + push(@v, $v); + } + } + return wantarray ? @v : $v[0]; + } + } + else { + # list parameter names + my @n; + my %seen; + for ($self->inputs) { + my $n = $_->name; + next if !defined($n) || $seen{$n}++; + push(@n, $n); + } + return @n; + } +} + + +=item $form->try_others( \&callback ) + +This method will iterate over all permutations of unvisited enumerated +values (<select>, <radio>, <checkbox>) and invoke the callback for +each. The callback is passed the $form as argument. The return value +from the callback is ignored and the try_others() method itself does +not return anything. + +=cut + +sub try_others +{ + my($self, $cb) = @_; + my @try; + for (@{$self->{'inputs'}}) { + my @not_tried_yet = $_->other_possible_values; + next unless @not_tried_yet; + push(@try, [\@not_tried_yet, $_]); + } + return unless @try; + $self->_try($cb, \@try, 0); +} + +sub _try +{ + my($self, $cb, $try, $i) = @_; + for (@{$try->[$i][0]}) { + $try->[$i][1]->value($_); + &$cb($self); + $self->_try($cb, $try, $i+1) if $i+1 < @$try; + } +} + + +=item $request = $form->make_request + +Will return an C<HTTP::Request> object that reflects the current setting +of the form. You might want to use the click() method instead. + +=cut + +sub make_request +{ + my $self = shift; + my $method = uc $self->{'method'}; + my $uri = $self->{'action'}; + my $enctype = $self->{'enctype'}; + my @form = $self->form; + + my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset; + if ($Encode_available) { + foreach my $fi (@form) { + $fi = Encode::encode($charset, $fi) unless ref($fi); + } + } + + if ($method eq "GET") { + require HTTP::Request; + $uri = URI->new($uri, "http"); + $uri->query_form(@form); + return HTTP::Request->new(GET => $uri); + } + elsif ($method eq "POST") { + require HTTP::Request::Common; + return HTTP::Request::Common::POST($uri, \@form, + Content_Type => $enctype); + } + else { + Carp::croak("Unknown method '$method'"); + } +} + + +=item $request = $form->click + +=item $request = $form->click( $selector ) + +=item $request = $form->click( $x, $y ) + +=item $request = $form->click( $selector, $x, $y ) + +Will "click" on the first clickable input (which will be of type +C<submit> or C<image>). The result of clicking is an C<HTTP::Request> +object that can then be passed to C<LWP::UserAgent> if you want to +obtain the server response. + +If a $selector is specified, we will click on the first clickable input +matching the selector, and the method will croak if no matching clickable +input is found. If $selector is I<not> specified, then it +is ok if the form contains no clickable inputs. In this case the +click() method returns the same request as the make_request() method +would do. See description of the find_input() method above for how +the $selector is specified. + +If there are multiple clickable inputs with the same name, then there +is no way to get the click() method of the C<HTML::Form> to click on +any but the first. If you need this you would have to locate the +input with find_input() and invoke the click() method on the given +input yourself. + +A click coordinate pair can also be provided, but this only makes a +difference if you clicked on an image. The default coordinate is +(1,1). The upper-left corner of the image is (0,0), but some badly +coded CGI scripts are known to not recognize this. Therefore (1,1) was +selected as a safer default. + +=cut + +sub click +{ + my $self = shift; + my $name; + $name = shift if (@_ % 2) == 1; # odd number of arguments + + # try to find first submit button to activate + for (@{$self->{'inputs'}}) { + next unless $_->can("click"); + next if $name && !$_->selected($name); + next if $_->disabled; + return $_->click($self, @_); + } + Carp::croak("No clickable input with name $name") if $name; + $self->make_request; +} + + +=item @kw = $form->form + +Returns the current setting as a sequence of key/value pairs. Note +that keys might be repeated, which means that some values might be +lost if the return values are assigned to a hash. + +In scalar context this method returns the number of key/value pairs +generated. + +=cut + +sub form +{ + my $self = shift; + map { $_->form_name_value($self) } @{$self->{'inputs'}}; +} + + +=item $form->dump + +Returns a textual representation of current state of the form. Mainly +useful for debugging. If called in void context, then the dump is +printed on STDERR. + +=cut + +sub dump +{ + my $self = shift; + my $method = $self->{'method'}; + my $uri = $self->{'action'}; + my $enctype = $self->{'enctype'}; + my $dump = "$method $uri"; + $dump .= " ($enctype)" + if $enctype ne "application/x-www-form-urlencoded"; + $dump .= " [$self->{attr}{name}]" + if exists $self->{attr}{name}; + $dump .= "\n"; + for ($self->inputs) { + $dump .= " " . $_->dump . "\n"; + } + print STDERR $dump unless defined wantarray; + $dump; +} + + +#--------------------------------------------------- +package HTML::Form::Input; + +=back + +=head1 INPUTS + +An C<HTML::Form> objects contains a sequence of I<inputs>. References to +the inputs can be obtained with the $form->inputs or $form->find_input +methods. + +Note that there is I<not> a one-to-one correspondence between input +I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An +input object basically represents a name/value pair, so when multiple +HTML elements contribute to the same name/value pair in the submitted +form they are combined. + +The input elements that are mapped one-to-one are "text", "textarea", +"password", "hidden", "file", "image", "submit" and "checkbox". For +the "radio" and "option" inputs the story is not as simple: All +E<lt>input type="radio"E<gt> elements with the same name will +contribute to the same input radio object. The number of radio input +objects will be the same as the number of distinct names used for the +E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element +without the C<multiple> attribute there will be one input object of +type of "option". For a E<lt>select multipleE<gt> element there will +be one input object for each contained E<lt>optionE<gt> element. Each +one of these option objects will have the same name. + +The following methods are available for the I<input> objects: + +=over 4 + +=cut + +sub new +{ + my $class = shift; + my $self = bless {@_}, $class; + $self; +} + +sub add_to_form +{ + my($self, $form) = @_; + push(@{$form->{'inputs'}}, $self); + $self; +} + +sub strict { + my $self = shift; + my $old = $self->{strict}; + if (@_) { + $self->{strict} = shift; + } + $old; +} + +sub fixup {} + + +=item $input->type + +Returns the type of this input. The type is one of the following +strings: "text", "password", "hidden", "textarea", "file", "image", "submit", +"radio", "checkbox" or "option". + +=cut + +sub type +{ + shift->{type}; +} + +=item $name = $input->name + +=item $input->name( $new_name ) + +This method can be used to get/set the current name of the input. + +=item $input->id + +=item $input->class + +These methods can be used to get/set the current id or class attribute for the input. + +=item $input->selected( $selector ) + +Returns TRUE if the given selector matched the input. See the description of +the find_input() method above for a description of the selector syntax. + +=item $value = $input->value + +=item $input->value( $new_value ) + +This method can be used to get/set the current value of an +input. + +If strict is enabled and the input only can take an enumerated list of values, +then it is an error to try to set it to something else and the method will +croak if you try. + +You will also be able to set the value of read-only inputs, but a +warning will be generated if running under C<perl -w>. + +=cut + +sub name +{ + my $self = shift; + my $old = $self->{name}; + $self->{name} = shift if @_; + $old; +} + +sub id +{ + my $self = shift; + my $old = $self->{id}; + $self->{id} = shift if @_; + $old; +} + +sub class +{ + my $self = shift; + my $old = $self->{class}; + $self->{class} = shift if @_; + $old; +} + +sub selected { + my($self, $sel) = @_; + return undef unless defined $sel; + my $attr = + $sel =~ s/^\^// ? "name" : + $sel =~ s/^#// ? "id" : + $sel =~ s/^\.// ? "class" : + "name"; + return 0 unless defined $self->{$attr}; + return $self->{$attr} eq $sel; +} + +sub value +{ + my $self = shift; + my $old = $self->{value}; + $self->{value} = shift if @_; + $old; +} + +=item $input->possible_values + +Returns a list of all values that an input can take. For inputs that +do not have discrete values, this returns an empty list. + +=cut + +sub possible_values +{ + return; +} + +=item $input->other_possible_values + +Returns a list of all values not tried yet. + +=cut + +sub other_possible_values +{ + return; +} + +=item $input->value_names + +For some inputs the values can have names that are different from the +values themselves. The number of names returned by this method will +match the number of values reported by $input->possible_values. + +When setting values using the value() method it is also possible to +use the value names in place of the value itself. + +=cut + +sub value_names { + return +} + +=item $bool = $input->readonly + +=item $input->readonly( $bool ) + +This method is used to get/set the value of the readonly attribute. +You are allowed to modify the value of readonly inputs, but setting +the value will generate some noise when warnings are enabled. Hidden +fields always start out readonly. + +=cut + +sub readonly { + my $self = shift; + my $old = $self->{readonly}; + $self->{readonly} = shift if @_; + $old; +} + +=item $bool = $input->disabled + +=item $input->disabled( $bool ) + +This method is used to get/set the value of the disabled attribute. +Disabled inputs do not contribute any key/value pairs for the form +value. + +=cut + +sub disabled { + my $self = shift; + my $old = $self->{disabled}; + $self->{disabled} = shift if @_; + $old; +} + +=item $input->form_name_value + +Returns a (possible empty) list of key/value pairs that should be +incorporated in the form value from this input. + +=cut + +sub form_name_value +{ + my $self = shift; + my $name = $self->{'name'}; + return unless defined $name; + return if $self->disabled; + my $value = $self->value; + return unless defined $value; + return ($name => $value); +} + +sub dump +{ + my $self = shift; + my $name = $self->name; + $name = "<NONAME>" unless defined $name; + my $value = $self->value; + $value = "<UNDEF>" unless defined $value; + my $dump = "$name=$value"; + + my $type = $self->type; + + $type .= " disabled" if $self->disabled; + $type .= " readonly" if $self->readonly; + return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu}; + + my @menu; + my $i = 0; + for (@{$self->{menu}}) { + my $opt = $_->{value}; + $opt = "<UNDEF>" unless defined $opt; + $opt .= "/$_->{name}" + if defined $_->{name} && length $_->{name} && $_->{name} ne $opt; + substr($opt,0,0) = "-" if $_->{disabled}; + if (exists $self->{current} && $self->{current} == $i) { + substr($opt,0,0) = "!" unless $_->{seen}; + substr($opt,0,0) = "*"; + } + else { + substr($opt,0,0) = ":" if $_->{seen}; + } + push(@menu, $opt); + $i++; + } + + return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]"; +} + + +#--------------------------------------------------- +package HTML::Form::TextInput; +@HTML::Form::TextInput::ISA=qw(HTML::Form::Input); + +#input/text +#input/password +#input/hidden +#textarea + +sub value +{ + my $self = shift; + my $old = $self->{value}; + $old = "" unless defined $old; + if (@_) { + Carp::croak("Input '$self->{name}' is readonly") + if $self->{strict} && $self->{readonly}; + my $new = shift; + my $n = exists $self->{maxlength} ? $self->{maxlength} : undef; + Carp::croak("Input '$self->{name}' has maxlength '$n'") + if $self->{strict} && defined($n) && defined($new) && length($new) > $n; + $self->{value} = $new; + } + $old; +} + +#--------------------------------------------------- +package HTML::Form::IgnoreInput; +@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input); + +#input/button +#input/reset + +sub value { return } + + +#--------------------------------------------------- +package HTML::Form::ListInput; +@HTML::Form::ListInput::ISA=qw(HTML::Form::Input); + +#select/option (val1, val2, ....) +#input/radio (undef, val1, val2,...) +#input/checkbox (undef, value) +#select-multiple/option (undef, value) + +sub new +{ + my $class = shift; + my $self = $class->SUPER::new(@_); + + my $value = delete $self->{value}; + my $value_name = delete $self->{value_name}; + my $type = $self->{type}; + + if ($type eq "checkbox") { + $value = "on" unless defined $value; + $self->{menu} = [ + { value => undef, name => "off", }, + { value => $value, name => $value_name, }, + ]; + $self->{current} = (delete $self->{checked}) ? 1 : 0; + ; + } + else { + $self->{option_disabled}++ + if $type eq "radio" && delete $self->{disabled}; + $self->{menu} = [ + {value => $value, name => $value_name}, + ]; + my $checked = $self->{checked} || $self->{option_selected}; + delete $self->{checked}; + delete $self->{option_selected}; + if (exists $self->{multiple}) { + unshift(@{$self->{menu}}, { value => undef, name => "off"}); + $self->{current} = $checked ? 1 : 0; + } + else { + $self->{current} = 0 if $checked; + } + } + $self; +} + +sub add_to_form +{ + my($self, $form) = @_; + my $type = $self->type; + + return $self->SUPER::add_to_form($form) + if $type eq "checkbox"; + + if ($type eq "option" && exists $self->{multiple}) { + $self->{disabled} ||= delete $self->{option_disabled}; + return $self->SUPER::add_to_form($form); + } + + die "Assert" if @{$self->{menu}} != 1; + my $m = $self->{menu}[0]; + $m->{disabled}++ if delete $self->{option_disabled}; + + my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx}); + return $self->SUPER::add_to_form($form) unless $prev; + + # merge menues + $prev->{current} = @{$prev->{menu}} if exists $self->{current}; + push(@{$prev->{menu}}, $m); +} + +sub fixup +{ + my $self = shift; + if ($self->{type} eq "option" && !(exists $self->{current})) { + $self->{current} = 0; + } + $self->{menu}[$self->{current}]{seen}++ if exists $self->{current}; +} + +sub disabled +{ + my $self = shift; + my $type = $self->type; + + my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}}); + if (@_) { + my $v = shift; + $self->{disabled} = $v; + for (@{$self->{menu}}) { + $_->{disabled} = $v; + } + } + return $old; +} + +sub _menu_all_disabled { + for (@_) { + return 0 unless $_->{disabled}; + } + return 1; +} + +sub value +{ + my $self = shift; + my $old; + $old = $self->{menu}[$self->{current}]{value} if exists $self->{current}; + $old = $self->{value} if exists $self->{value}; + if (@_) { + my $i = 0; + my $val = shift; + my $cur; + my $disabled; + for (@{$self->{menu}}) { + if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) || + (!defined($val) && !defined($_->{value})) + ) + { + $cur = $i; + $disabled = $_->{disabled}; + last unless $disabled; + } + $i++; + } + if (!(defined $cur) || $disabled) { + if (defined $val) { + # try to search among the alternative names as well + my $i = 0; + my $cur_ignorecase; + my $lc_val = lc($val); + for (@{$self->{menu}}) { + if (defined $_->{name}) { + if ($val eq $_->{name}) { + $disabled = $_->{disabled}; + $cur = $i; + last unless $disabled; + } + if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) { + $cur_ignorecase = $i; + } + } + $i++; + } + unless (defined $cur) { + $cur = $cur_ignorecase; + if (defined $cur) { + $disabled = $self->{menu}[$cur]{disabled}; + } + elsif ($self->{strict}) { + my $n = $self->name; + Carp::croak("Illegal value '$val' for field '$n'"); + } + } + } + elsif ($self->{strict}) { + my $n = $self->name; + Carp::croak("The '$n' field can't be unchecked"); + } + } + if ($self->{strict} && $disabled) { + my $n = $self->name; + Carp::croak("The value '$val' has been disabled for field '$n'"); + } + if (defined $cur) { + $self->{current} = $cur; + $self->{menu}[$cur]{seen}++; + delete $self->{value}; + } + else { + $self->{value} = $val; + delete $self->{current}; + } + } + $old; +} + +=item $input->check + +Some input types represent toggles that can be turned on/off. This +includes "checkbox" and "option" inputs. Calling this method turns +this input on without having to know the value name. If the input is +already on, then nothing happens. + +This has the same effect as: + + $input->value($input->possible_values[1]); + +The input can be turned off with: + + $input->value(undef); + +=cut + +sub check +{ + my $self = shift; + $self->{current} = 1; + $self->{menu}[1]{seen}++; +} + +sub possible_values +{ + my $self = shift; + map $_->{value}, grep !$_->{disabled}, @{$self->{menu}}; +} + +sub other_possible_values +{ + my $self = shift; + map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}}; +} + +sub value_names { + my $self = shift; + my @names; + for (@{$self->{menu}}) { + my $n = $_->{name}; + $n = $_->{value} unless defined $n; + push(@names, $n); + } + @names; +} + + +#--------------------------------------------------- +package HTML::Form::SubmitInput; +@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input); + +#input/image +#input/submit + +=item $input->click($form, $x, $y) + +Some input types (currently "submit" buttons and "images") can be +clicked to submit the form. The click() method returns the +corresponding C<HTTP::Request> object. + +=cut + +sub click +{ + my($self,$form,$x,$y) = @_; + for ($x, $y) { $_ = 1 unless defined; } + local($self->{clicked}) = [$x,$y]; + return $form->make_request; +} + +sub form_name_value +{ + my $self = shift; + return unless $self->{clicked}; + return $self->SUPER::form_name_value(@_); +} + + +#--------------------------------------------------- +package HTML::Form::ImageInput; +@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput); + +sub form_name_value +{ + my $self = shift; + my $clicked = $self->{clicked}; + return unless $clicked; + return if $self->{disabled}; + my $name = $self->{name}; + $name = (defined($name) && length($name)) ? "$name." : ""; + return ("${name}x" => $clicked->[0], + "${name}y" => $clicked->[1] + ); +} + +#--------------------------------------------------- +package HTML::Form::FileInput; +@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput); + +=back + +If the input is of type C<file>, then it has these additional methods: + +=over 4 + +=item $input->file + +This is just an alias for the value() method. It sets the filename to +read data from. + +For security reasons this field will never be initialized from the parsing +of a form. This prevents the server from triggering stealth uploads of +arbitrary files from the client machine. + +=cut + +sub file { + my $self = shift; + $self->value(@_); +} + +=item $filename = $input->filename + +=item $input->filename( $new_filename ) + +This get/sets the filename reported to the server during file upload. +This attribute defaults to the value reported by the file() method. + +=cut + +sub filename { + my $self = shift; + my $old = $self->{filename}; + $self->{filename} = shift if @_; + $old = $self->file unless defined $old; + $old; +} + +=item $content = $input->content + +=item $input->content( $new_content ) + +This get/sets the file content provided to the server during file +upload. This method can be used if you do not want the content to be +read from an actual file. + +=cut + +sub content { + my $self = shift; + my $old = $self->{content}; + $self->{content} = shift if @_; + $old; +} + +=item @headers = $input->headers + +=item input->headers($key => $value, .... ) + +This get/set additional header fields describing the file uploaded. +This can for instance be used to set the C<Content-Type> reported for +the file. + +=cut + +sub headers { + my $self = shift; + my $old = $self->{headers} || []; + $self->{headers} = [@_] if @_; + @$old; +} + +sub form_name_value { + my($self, $form) = @_; + return $self->SUPER::form_name_value($form) + if $form->method ne "POST" || + $form->enctype ne "multipart/form-data"; + + my $name = $self->name; + return unless defined $name; + return if $self->{disabled}; + + my $file = $self->file; + my $filename = $self->filename; + my @headers = $self->headers; + my $content = $self->content; + if (defined $content) { + $filename = $file unless defined $filename; + $file = undef; + unshift(@headers, "Content" => $content); + } + elsif (!defined($file) || length($file) == 0) { + return; + } + + # legacy (this used to be the way to do it) + if (ref($file) eq "ARRAY") { + my $f = shift @$file; + my $fn = shift @$file; + push(@headers, @$file); + $file = $f; + $filename = $fn unless defined $filename; + } + + return ($name => [$file, $filename, @headers]); +} + +package HTML::Form::KeygenInput; +@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input); + +sub challenge { + my $self = shift; + return $self->{challenge}; +} + +sub keytype { + my $self = shift; + return lc($self->{keytype} || 'rsa'); +} + +1; + +__END__ + +=back + +=head1 SEE ALSO + +L<LWP>, L<LWP::UserAgent>, L<HTML::Parser> + +=head1 COPYRIGHT + +Copyright 1998-2008 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/HTML/HeadParser.pm b/Master/tlpkg/tlperl/lib/HTML/HeadParser.pm new file mode 100755 index 00000000000..cb1f3b612a8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/HeadParser.pm @@ -0,0 +1,301 @@ +package HTML::HeadParser; + +=head1 NAME + +HTML::HeadParser - Parse <HEAD> section of a HTML document + +=head1 SYNOPSIS + + require HTML::HeadParser; + $p = HTML::HeadParser->new; + $p->parse($text) and print "not finished"; + + $p->header('Title') # to access <title>....</title> + $p->header('Content-Base') # to access <base href="http://..."> + $p->header('Foo') # to access <meta http-equiv="Foo" content="..."> + $p->header('X-Meta-Author') # to access <meta name="author" content="..."> + $p->header('X-Meta-Charset') # to access <meta charset="..."> + +=head1 DESCRIPTION + +The C<HTML::HeadParser> is a specialized (and lightweight) +C<HTML::Parser> that will only parse the E<lt>HEAD>...E<lt>/HEAD> +section of an HTML document. The parse() method +will return a FALSE value as soon as some E<lt>BODY> element or body +text are found, and should not be called again after this. + +Note that the C<HTML::HeadParser> might get confused if raw undecoded +UTF-8 is passed to the parse() method. Make sure the strings are +properly decoded before passing them on. + +The C<HTML::HeadParser> keeps a reference to a header object, and the +parser will update this header object as the various elements of the +E<lt>HEAD> section of the HTML document are recognized. The following +header fields are affected: + +=over 4 + +=item Content-Base: + +The I<Content-Base> header is initialized from the E<lt>base +href="..."> element. + +=item Title: + +The I<Title> header is initialized from the E<lt>title>...E<lt>/title> +element. + +=item Isindex: + +The I<Isindex> header will be added if there is a E<lt>isindex> +element in the E<lt>head>. The header value is initialized from the +I<prompt> attribute if it is present. If no I<prompt> attribute is +given it will have '?' as the value. + +=item X-Meta-Foo: + +All E<lt>meta> elements containing a C<name> attribute will result in +headers using the prefix C<X-Meta-> appended with the value of the +C<name> attribute as the name of the header, and the value of the +C<content> attribute as the pushed header value. + +E<lt>meta> elements containing a C<http-equiv> attribute will result +in headers as in above, but without the C<X-Meta-> prefix in the +header name. + +E<lt>meta> elements containing a C<charset> attribute will result in +an C<X-Meta-Charset> header, using the value of the C<charset> +attribute as the pushed header value. + +=back + +=head1 METHODS + +The following methods (in addition to those provided by the +superclass) are available: + +=over 4 + +=cut + + +require HTML::Parser; +@ISA = qw(HTML::Parser); + +use HTML::Entities (); + +use strict; +use vars qw($VERSION $DEBUG); +#$DEBUG = 1; +$VERSION = "3.62"; + +=item $hp = HTML::HeadParser->new + +=item $hp = HTML::HeadParser->new( $header ) + +The object constructor. The optional $header argument should be a +reference to an object that implement the header() and push_header() +methods as defined by the C<HTTP::Headers> class. Normally it will be +of some class that is a or delegates to the C<HTTP::Headers> class. + +If no $header is given C<HTML::HeadParser> will create an +C<HTTP::Headers> object by itself (initially empty). + +=cut + +sub new +{ + my($class, $header) = @_; + unless ($header) { + require HTTP::Headers; + $header = HTTP::Headers->new; + } + + my $self = $class->SUPER::new(api_version => 3, + start_h => ["start", "self,tagname,attr"], + end_h => ["end", "self,tagname"], + text_h => ["text", "self,text"], + ignore_elements => [qw(script style)], + ); + $self->{'header'} = $header; + $self->{'tag'} = ''; # name of active element that takes textual content + $self->{'text'} = ''; # the accumulated text associated with the element + $self; +} + +=item $hp->header; + +Returns a reference to the header object. + +=item $hp->header( $key ) + +Returns a header value. It is just a shorter way to write +C<$hp-E<gt>header-E<gt>header($key)>. + +=cut + +sub header +{ + my $self = shift; + return $self->{'header'} unless @_; + $self->{'header'}->header(@_); +} + +sub as_string # legacy +{ + my $self = shift; + $self->{'header'}->as_string; +} + +sub flush_text # internal +{ + my $self = shift; + my $tag = $self->{'tag'}; + my $text = $self->{'text'}; + $text =~ s/^\s+//; + $text =~ s/\s+$//; + $text =~ s/\s+/ /g; + print "FLUSH $tag => '$text'\n" if $DEBUG; + if ($tag eq 'title') { + HTML::Entities::decode($text); + $self->{'header'}->push_header(Title => $text); + } + $self->{'tag'} = $self->{'text'} = ''; +} + +# This is an quote from the HTML3.2 DTD which shows which elements +# that might be present in a <HEAD>...</HEAD>. Also note that the +# <HEAD> tags themselves might be missing: +# +# <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? & +# SCRIPT* & META* & LINK*"> +# +# <!ELEMENT HEAD O O (%head.content)> +# +# From HTML 4.01: +# +# <!ENTITY % head.misc "SCRIPT|STYLE|META|LINK|OBJECT"> +# <!ENTITY % head.content "TITLE & BASE?"> +# <!ELEMENT HEAD O O (%head.content;) +(%head.misc;)> +# +# Added in HTML 5 as of WD-html5-20090423: noscript, command + +sub start +{ + my($self, $tag, $attr) = @_; # $attr is reference to a HASH + print "START[$tag]\n" if $DEBUG; + $self->flush_text if $self->{'tag'}; + if ($tag eq 'meta') { + my $key = $attr->{'http-equiv'}; + if (!defined($key) || !length($key)) { + if ($attr->{name}) { + $key = "X-Meta-\u$attr->{name}"; + } elsif ($attr->{charset}) { # HTML 5 <meta charset="..."> + $key = "X-Meta-Charset"; + $self->{header}->push_header($key => $attr->{charset}); + return; + } else { + return; + } + } + $self->{'header'}->push_header($key => $attr->{content}); + } elsif ($tag eq 'base') { + return unless exists $attr->{href}; + $self->{'header'}->push_header('Content-Base' => $attr->{href}); + } elsif ($tag eq 'isindex') { + # This is a non-standard header. Perhaps we should just ignore + # this element + $self->{'header'}->push_header(Isindex => $attr->{prompt} || '?'); + } elsif ($tag =~ /^(?:title|noscript|object|command)$/) { + # Just remember tag. Initialize header when we see the end tag. + $self->{'tag'} = $tag; + } elsif ($tag eq 'link') { + return unless exists $attr->{href}; + # <link href="http:..." rel="xxx" rev="xxx" title="xxx"> + my $h_val = "<" . delete($attr->{href}) . ">"; + for (sort keys %{$attr}) { + next if $_ eq "/"; # XHTML junk + $h_val .= qq(; $_="$attr->{$_}"); + } + $self->{'header'}->push_header(Link => $h_val); + } elsif ($tag eq 'head' || $tag eq 'html') { + # ignore + } else { + # stop parsing + $self->eof; + } +} + +sub end +{ + my($self, $tag) = @_; + print "END[$tag]\n" if $DEBUG; + $self->flush_text if $self->{'tag'}; + $self->eof if $tag eq 'head'; +} + +sub text +{ + my($self, $text) = @_; + print "TEXT[$text]\n" if $DEBUG; + unless ($self->{first_chunk}) { + # drop Unicode BOM if found + if ($self->utf8_mode) { + $text =~ s/^\xEF\xBB\xBF//; + } + else { + $text =~ s/^\x{FEFF}//; + } + $self->{first_chunk}++; + } + my $tag = $self->{tag}; + if (!$tag && $text =~ /\S/) { + # Normal text means start of body + $self->eof; + return; + } + return if $tag ne 'title'; + $self->{'text'} .= $text; +} + +BEGIN { + *utf8_mode = sub { 1 } unless HTML::Entities::UNICODE_SUPPORT;; +} + +1; + +__END__ + +=back + +=head1 EXAMPLE + + $h = HTTP::Headers->new; + $p = HTML::HeadParser->new($h); + $p->parse(<<EOT); + <title>Stupid example</title> + <base href="http://www.linpro.no/lwp/"> + Normal text starts here. + EOT + undef $p; + print $h->title; # should print "Stupid example" + +=head1 SEE ALSO + +L<HTML::Parser>, L<HTTP::Headers> + +The C<HTTP::Headers> class is distributed as part of the +I<libwww-perl> package. If you don't have that distribution installed +you need to provide the $header argument to the C<HTML::HeadParser> +constructor with your own object that implements the documented +protocol. + +=head1 COPYRIGHT + +Copyright 1996-2001 Gisle Aas. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/HTML/LinkExtor.pm b/Master/tlpkg/tlperl/lib/HTML/LinkExtor.pm new file mode 100755 index 00000000000..8d50439d15f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/LinkExtor.pm @@ -0,0 +1,185 @@ +package HTML::LinkExtor; + +require HTML::Parser; +@ISA = qw(HTML::Parser); +$VERSION = "3.60"; + +=head1 NAME + +HTML::LinkExtor - Extract links from an HTML document + +=head1 SYNOPSIS + + require HTML::LinkExtor; + $p = HTML::LinkExtor->new(\&cb, "http://www.perl.org/"); + sub cb { + my($tag, %links) = @_; + print "$tag @{[%links]}\n"; + } + $p->parse_file("index.html"); + +=head1 DESCRIPTION + +I<HTML::LinkExtor> is an HTML parser that extracts links from an +HTML document. The I<HTML::LinkExtor> is a subclass of +I<HTML::Parser>. This means that the document should be given to the +parser by calling the $p->parse() or $p->parse_file() methods. + +=cut + +use strict; +use HTML::Tagset (); + +# legacy (some applications grabs this hash directly) +use vars qw(%LINK_ELEMENT); +*LINK_ELEMENT = \%HTML::Tagset::linkElements; + +=over 4 + +=item $p = HTML::LinkExtor->new + +=item $p = HTML::LinkExtor->new( $callback ) + +=item $p = HTML::LinkExtor->new( $callback, $base ) + +The constructor takes two optional arguments. The first is a reference +to a callback routine. It will be called as links are found. If a +callback is not provided, then links are just accumulated internally +and can be retrieved by calling the $p->links() method. + +The $base argument is an optional base URL used to absolutize all URLs found. +You need to have the I<URI> module installed if you provide $base. + +The callback is called with the lowercase tag name as first argument, +and then all link attributes as separate key/value pairs. All +non-link attributes are removed. + +=cut + +sub new +{ + my($class, $cb, $base) = @_; + my $self = $class->SUPER::new( + start_h => ["_start_tag", "self,tagname,attr"], + report_tags => [keys %HTML::Tagset::linkElements], + ); + $self->{extractlink_cb} = $cb; + if ($base) { + require URI; + $self->{extractlink_base} = URI->new($base); + } + $self; +} + +sub _start_tag +{ + my($self, $tag, $attr) = @_; + + my $base = $self->{extractlink_base}; + my $links = $HTML::Tagset::linkElements{$tag}; + $links = [$links] unless ref $links; + + my @links; + my $a; + for $a (@$links) { + next unless exists $attr->{$a}; + push(@links, $a, $base ? URI->new($attr->{$a}, $base)->abs($base) + : $attr->{$a}); + } + return unless @links; + $self->_found_link($tag, @links); +} + +sub _found_link +{ + my $self = shift; + my $cb = $self->{extractlink_cb}; + if ($cb) { + &$cb(@_); + } else { + push(@{$self->{'links'}}, [@_]); + } +} + +=item $p->links + +Returns a list of all links found in the document. The returned +values will be anonymous arrays with the following elements: + + [$tag, $attr => $url1, $attr2 => $url2,...] + +The $p->links method will also truncate the internal link list. This +means that if the method is called twice without any parsing +between them the second call will return an empty list. + +Also note that $p->links will always be empty if a callback routine +was provided when the I<HTML::LinkExtor> was created. + +=cut + +sub links +{ + my $self = shift; + exists($self->{'links'}) ? @{delete $self->{'links'}} : (); +} + +# We override the parse_file() method so that we can clear the links +# before we start a new file. +sub parse_file +{ + my $self = shift; + delete $self->{'links'}; + $self->SUPER::parse_file(@_); +} + +=back + +=head1 EXAMPLE + +This is an example showing how you can extract links from a document +received using LWP: + + use LWP::UserAgent; + use HTML::LinkExtor; + use URI::URL; + + $url = "http://www.perl.org/"; # for instance + $ua = LWP::UserAgent->new; + + # Set up a callback that collect image links + my @imgs = (); + sub callback { + my($tag, %attr) = @_; + return if $tag ne 'img'; # we only look closer at <img ...> + push(@imgs, values %attr); + } + + # Make the parser. Unfortunately, we don't know the base yet + # (it might be different from $url) + $p = HTML::LinkExtor->new(\&callback); + + # Request document and parse it as it arrives + $res = $ua->request(HTTP::Request->new(GET => $url), + sub {$p->parse($_[0])}); + + # Expand all image URLs to absolute ones + my $base = $res->base; + @imgs = map { $_ = url($_, $base)->abs; } @imgs; + + # Print them out + print join("\n", @imgs), "\n"; + +=head1 SEE ALSO + +L<HTML::Parser>, L<HTML::Tagset>, L<LWP>, L<URI::URL> + +=head1 COPYRIGHT + +Copyright 1996-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/HTML/Parser.pm b/Master/tlpkg/tlperl/lib/HTML/Parser.pm new file mode 100755 index 00000000000..55cf8d9c51d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/Parser.pm @@ -0,0 +1,1240 @@ +package HTML::Parser; + +# Copyright 1996-2009, Gisle Aas. +# Copyright 1999-2000, Michael A. Chase. +# +# This library is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "3.64"; + +require HTML::Entities; + +require XSLoader; +XSLoader::load('HTML::Parser', $VERSION); + +sub new +{ + my $class = shift; + my $self = bless {}, $class; + return $self->init(@_); +} + + +sub init +{ + my $self = shift; + $self->_alloc_pstate; + + my %arg = @_; + my $api_version = delete $arg{api_version} || (@_ ? 3 : 2); + if ($api_version >= 4) { + require Carp; + Carp::croak("API version $api_version not supported " . + "by HTML::Parser $VERSION"); + } + + if ($api_version < 3) { + # Set up method callbacks compatible with HTML-Parser-2.xx + $self->handler(text => "text", "self,text,is_cdata"); + $self->handler(end => "end", "self,tagname,text"); + $self->handler(process => "process", "self,token0,text"); + $self->handler(start => "start", + "self,tagname,attr,attrseq,text"); + + $self->handler(comment => + sub { + my($self, $tokens) = @_; + for (@$tokens) { + $self->comment($_); + } + }, "self,tokens"); + + $self->handler(declaration => + sub { + my $self = shift; + $self->declaration(substr($_[0], 2, -1)); + }, "self,text"); + } + + if (my $h = delete $arg{handlers}) { + $h = {@$h} if ref($h) eq "ARRAY"; + while (my($event, $cb) = each %$h) { + $self->handler($event => @$cb); + } + } + + # In the end we try to assume plain attribute or handler + while (my($option, $val) = each %arg) { + if ($option =~ /^(\w+)_h$/) { + $self->handler($1 => @$val); + } + elsif ($option =~ /^(text|start|end|process|declaration|comment)$/) { + require Carp; + Carp::croak("Bad constructor option '$option'"); + } + else { + $self->$option($val); + } + } + + return $self; +} + + +sub parse_file +{ + my($self, $file) = @_; + my $opened; + if (!ref($file) && ref(\$file) ne "GLOB") { + # Assume $file is a filename + local(*F); + open(F, "<", $file) || return undef; + binmode(F); # should we? good for byte counts + $opened++; + $file = *F; + } + my $chunk = ''; + while (read($file, $chunk, 512)) { + $self->parse($chunk) || last; + } + close($file) if $opened; + $self->eof; +} + + +sub netscape_buggy_comment # legacy +{ + my $self = shift; + require Carp; + Carp::carp("netscape_buggy_comment() is deprecated. " . + "Please use the strict_comment() method instead"); + my $old = !$self->strict_comment; + $self->strict_comment(!shift) if @_; + return $old; +} + +# set up method stubs +sub text { } +*start = \&text; +*end = \&text; +*comment = \&text; +*declaration = \&text; +*process = \&text; + +1; + +__END__ + + +=head1 NAME + +HTML::Parser - HTML parser class + +=head1 SYNOPSIS + + use HTML::Parser (); + + # Create parser object + $p = HTML::Parser->new( api_version => 3, + start_h => [\&start, "tagname, attr"], + end_h => [\&end, "tagname"], + marked_sections => 1, + ); + + # Parse document text chunk by chunk + $p->parse($chunk1); + $p->parse($chunk2); + #... + $p->eof; # signal end of document + + # Parse directly from file + $p->parse_file("foo.html"); + # or + open(my $fh, "<:utf8", "foo.html") || die; + $p->parse_file($fh); + +=head1 DESCRIPTION + +Objects of the C<HTML::Parser> class will recognize markup and +separate it from plain text (alias data content) in HTML +documents. As different kinds of markup and text are recognized, the +corresponding event handlers are invoked. + +C<HTML::Parser> is not a generic SGML parser. We have tried to +make it able to deal with the HTML that is actually "out there", and +it normally parses as closely as possible to the way the popular web +browsers do it instead of strictly following one of the many HTML +specifications from W3C. Where there is disagreement, there is often +an option that you can enable to get the official behaviour. + +The document to be parsed may be supplied in arbitrary chunks. This +makes on-the-fly parsing as documents are received from the network +possible. + +If event driven parsing does not feel right for your application, you +might want to use C<HTML::PullParser>. This is an C<HTML::Parser> +subclass that allows a more conventional program structure. + + +=head1 METHODS + +The following method is used to construct a new C<HTML::Parser> object: + +=over + +=item $p = HTML::Parser->new( %options_and_handlers ) + +This class method creates a new C<HTML::Parser> object and +returns it. Key/value argument pairs may be provided to assign event +handlers or initialize parser options. The handlers and parser +options can also be set or modified later by the method calls described below. + +If a top level key is in the form "<event>_h" (e.g., "text_h") then it +assigns a handler to that event, otherwise it initializes a parser +option. The event handler specification value must be an array +reference. Multiple handlers may also be assigned with the 'handlers +=> [%handlers]' option. See examples below. + +If new() is called without any arguments, it will create a parser that +uses callback methods compatible with version 2 of C<HTML::Parser>. +See the section on "version 2 compatibility" below for details. + +The special constructor option 'api_version => 2' can be used to +initialize version 2 callbacks while still setting other options and +handlers. The 'api_version => 3' option can be used if you don't want +to set any options and don't want to fall back to v2 compatible +mode. + +Examples: + + $p = HTML::Parser->new(api_version => 3, + text_h => [ sub {...}, "dtext" ]); + +This creates a new parser object with a text event handler subroutine +that receives the original text with general entities decoded. + + $p = HTML::Parser->new(api_version => 3, + start_h => [ 'my_start', "self,tokens" ]); + +This creates a new parser object with a start event handler method +that receives the $p and the tokens array. + + $p = HTML::Parser->new(api_version => 3, + handlers => { text => [\@array, "event,text"], + comment => [\@array, "event,text"], + }); + +This creates a new parser object that stores the event type and the +original text in @array for text and comment events. + +=back + +The following methods feed the HTML document +to the C<HTML::Parser> object: + +=over + +=item $p->parse( $string ) + +Parse $string as the next chunk of the HTML document. Handlers invoked should +not attempt to modify the $string in-place until $p->parse returns. + +If an invoked event handler aborts parsing by calling $p->eof, then $p->parse() +will return a FALSE value. Otherwise the return value is a reference to the +parser object ($p). + +=item $p->parse( $code_ref ) + +If a code reference is passed as the argument to be parsed, then the +chunks to be parsed are obtained by invoking this function repeatedly. +Parsing continues until the function returns an empty (or undefined) +result. When this happens $p->eof is automatically signaled. + +Parsing will also abort if one of the event handlers calls $p->eof. + +The effect of this is the same as: + + while (1) { + my $chunk = &$code_ref(); + if (!defined($chunk) || !length($chunk)) { + $p->eof; + return $p; + } + $p->parse($chunk) || return undef; + } + +But it is more efficient as this loop runs internally in XS code. + +=item $p->parse_file( $file ) + +Parse text directly from a file. The $file argument can be a +filename, an open file handle, or a reference to an open file +handle. + +If $file contains a filename and the file can't be opened, then the +method returns an undefined value and $! tells why it failed. +Otherwise the return value is a reference to the parser object. + +If a file handle is passed as the $file argument, then the file will +normally be read until EOF, but not closed. + +If an invoked event handler aborts parsing by calling $p->eof, +then $p->parse_file() may not have read the entire file. + +On systems with multi-byte line terminators, the values passed for the +offset and length argspecs may be too low if parse_file() is called on +a file handle that is not in binary mode. + +If a filename is passed in, then parse_file() will open the file in +binary mode. + +=item $p->eof + +Signals the end of the HTML document. Calling the $p->eof method +outside a handler callback will flush any remaining buffered text +(which triggers the C<text> event if there is any remaining text). + +Calling $p->eof inside a handler will terminate parsing at that point +and cause $p->parse to return a FALSE value. This also terminates +parsing by $p->parse_file(). + +After $p->eof has been called, the parse() and parse_file() methods +can be invoked to feed new documents with the parser object. + +The return value from eof() is a reference to the parser object. + +=back + + +Most parser options are controlled by boolean attributes. +Each boolean attribute is enabled by calling the corresponding method +with a TRUE argument and disabled with a FALSE argument. The +attribute value is left unchanged if no argument is given. The return +value from each method is the old attribute value. + +Methods that can be used to get and/or set parser options are: + +=over + +=item $p->attr_encoded + +=item $p->attr_encoded( $bool ) + +By default, the C<attr> and C<@attr> argspecs will have general +entities for attribute values decoded. Enabling this attribute leaves +entities alone. + +=item $p->backquote + +=item $p->backquote( $bool ) + +By default, only ' and " are recognized as quote characters around +attribute values. MSIE also recognizes backquotes for some reason. +Enabling this attribute provides compatibility with this behaviour. + +=item $p->boolean_attribute_value( $val ) + +This method sets the value reported for boolean attributes inside HTML +start tags. By default, the name of the attribute is also used as its +value. This affects the values reported for C<tokens> and C<attr> +argspecs. + +=item $p->case_sensitive + +=item $p->case_sensitive( $bool ) + +By default, tagnames and attribute names are down-cased. Enabling this +attribute leaves them as found in the HTML source document. + +=item $p->closing_plaintext + +=item $p->closing_plaintext( $bool ) + +By default, "plaintext" element can never be closed. Everything up to +the end of the document is parsed in CDATA mode. This historical +behaviour is what at least MSIE does. Enabling this attribute makes +closing "</plaintext>" tag effective and the parsing process will resume +after seeing this tag. This emulates early gecko-based browsers. + +=item $p->empty_element_tags + +=item $p->empty_element_tags( $bool ) + +By default, empty element tags are not recognized as such and the "/" +before ">" is just treated like a normal name character (unless +C<strict_names> is enabled). Enabling this attribute make +C<HTML::Parser> recognize these tags. + +Empty element tags look like start tags, but end with the character +sequence "/>" instead of ">". When recognized by C<HTML::Parser> they +cause an artificial end event in addition to the start event. The +C<text> for the artificial end event will be empty and the C<tokenpos> +array will be undefined even though the the token array will have one +element containing the tag name. + +=item $p->marked_sections + +=item $p->marked_sections( $bool ) + +By default, section markings like <![CDATA[...]]> are treated like +ordinary text. When this attribute is enabled section markings are +honoured. + +There are currently no events associated with the marked section +markup, but the text can be returned as C<skipped_text>. + +=item $p->strict_comment + +=item $p->strict_comment( $bool ) + +By default, comments are terminated by the first occurrence of "-->". +This is the behaviour of most popular browsers (like Mozilla, Opera and +MSIE), but it is not correct according to the official HTML +standard. Officially, you need an even number of "--" tokens before +the closing ">" is recognized and there may not be anything but +whitespace between an even and an odd "--". + +The official behaviour is enabled by enabling this attribute. + +Enabling of 'strict_comment' also disables recognizing these forms as +comments: + + </ comment> + <! comment> + + +=item $p->strict_end + +=item $p->strict_end( $bool ) + +By default, attributes and other junk are allowed to be present on end tags in a +manner that emulates MSIE's behaviour. + +The official behaviour is enabled with this attribute. If enabled, +only whitespace is allowed between the tagname and the final ">". + +=item $p->strict_names + +=item $p->strict_names( $bool ) + +By default, almost anything is allowed in tag and attribute names. +This is the behaviour of most popular browsers and allows us to parse +some broken tags with invalid attribute values like: + + <IMG SRC=newprevlstGr.gif ALT=[PREV LIST] BORDER=0> + +By default, "LIST]" is parsed as a boolean attribute, not as +part of the ALT value as was clearly intended. This is also what +Mozilla sees. + +The official behaviour is enabled by enabling this attribute. If +enabled, it will cause the tag above to be reported as text +since "LIST]" is not a legal attribute name. + +=item $p->unbroken_text + +=item $p->unbroken_text( $bool ) + +By default, blocks of text are given to the text handler as soon as +possible (but the parser takes care always to break text at a +boundary between whitespace and non-whitespace so single words and +entities can always be decoded safely). This might create breaks that +make it hard to do transformations on the text. When this attribute is +enabled, blocks of text are always reported in one piece. This will +delay the text event until the following (non-text) event has been +recognized by the parser. + +Note that the C<offset> argspec will give you the offset of the first +segment of text and C<length> is the combined length of the segments. +Since there might be ignored tags in between, these numbers can't be +used to directly index in the original document file. + +=item $p->utf8_mode + +=item $p->utf8_mode( $bool ) + +Enable this option when parsing raw undecoded UTF-8. This tells the +parser that the entities expanded for strings reported by C<attr>, +C<@attr> and C<dtext> should be expanded as decoded UTF-8 so they end +up compatible with the surrounding text. + +If C<utf8_mode> is enabled then it is an error to pass strings +containing characters with code above 255 to the parse() method, and +the parse() method will croak if you try. + +Example: The Unicode character "\x{2665}" is "\xE2\x99\xA5" when UTF-8 +encoded. The character can also be represented by the entity +"♥" or "♥". If we feed the parser: + + $p->parse("\xE2\x99\xA5♥"); + +then C<dtext> will be reported as "\xE2\x99\xA5\x{2665}" without +C<utf8_mode> enabled, but as "\xE2\x99\xA5\xE2\x99\xA5" when enabled. +The later string is what you want. + +This option is only available with perl-5.8 or better. + +=item $p->xml_mode + +=item $p->xml_mode( $bool ) + +Enabling this attribute changes the parser to allow some XML +constructs. This enables the behaviour controlled by individually by +the C<case_sensitive>, C<empty_element_tags>, C<strict_names> and +C<xml_pic> attributes and also suppresses special treatment of +elements that are parsed as CDATA for HTML. + +=item $p->xml_pic + +=item $p->xml_pic( $bool ) + +By default, I<processing instructions> are terminated by ">". When +this attribute is enabled, processing instructions are terminated by +"?>" instead. + +=back + +As markup and text is recognized, handlers are invoked. The following +method is used to set up handlers for different events: + +=over + +=item $p->handler( event => \&subroutine, $argspec ) + +=item $p->handler( event => $method_name, $argspec ) + +=item $p->handler( event => \@accum, $argspec ) + +=item $p->handler( event => "" ); + +=item $p->handler( event => undef ); + +=item $p->handler( event ); + +This method assigns a subroutine, method, or array to handle an event. + +Event is one of C<text>, C<start>, C<end>, C<declaration>, C<comment>, +C<process>, C<start_document>, C<end_document> or C<default>. + +The C<\&subroutine> is a reference to a subroutine which is called to handle +the event. + +The C<$method_name> is the name of a method of $p which is called to handle +the event. + +The C<@accum> is an array that will hold the event information as +sub-arrays. + +If the second argument is "", the event is ignored. +If it is undef, the default handler is invoked for the event. + +The C<$argspec> is a string that describes the information to be reported +for the event. Any requested information that does not apply to a +specific event is passed as C<undef>. If argspec is omitted, then it +is left unchanged. + +The return value from $p->handler is the old callback routine or a +reference to the accumulator array. + +Any return values from handler callback routines/methods are always +ignored. A handler callback can request parsing to be aborted by +invoking the $p->eof method. A handler callback is not allowed to +invoke the $p->parse() or $p->parse_file() method. An exception will +be raised if it tries. + +Examples: + + $p->handler(start => "start", 'self, attr, attrseq, text' ); + +This causes the "start" method of object $p to be called for 'start' events. +The callback signature is $p->start(\%attr, \@attr_seq, $text). + + $p->handler(start => \&start, 'attr, attrseq, text' ); + +This causes subroutine start() to be called for 'start' events. +The callback signature is start(\%attr, \@attr_seq, $text). + + $p->handler(start => \@accum, '"S", attr, attrseq, text' ); + +This causes 'start' event information to be saved in @accum. +The array elements will be ['S', \%attr, \@attr_seq, $text]. + + $p->handler(start => ""); + +This causes 'start' events to be ignored. It also suppresses +invocations of any default handler for start events. It is in most +cases equivalent to $p->handler(start => sub {}), but is more +efficient. It is different from the empty-sub-handler in that +C<skipped_text> is not reset by it. + + $p->handler(start => undef); + +This causes no handler to be associated with start events. +If there is a default handler it will be invoked. + +=back + +Filters based on tags can be set up to limit the number of events +reported. The main bottleneck during parsing is often the huge number +of callbacks made from the parser. Applying filters can improve +performance significantly. + +The following methods control filters: + +=over + +=item $p->ignore_elements( @tags ) + +Both the C<start> event and the C<end> event as well as any events that +would be reported in between are suppressed. The ignored elements can +contain nested occurrences of itself. Example: + + $p->ignore_elements(qw(script style)); + +The C<script> and C<style> tags will always nest properly since their +content is parsed in CDATA mode. For most other tags +C<ignore_elements> must be used with caution since HTML is often not +I<well formed>. + +=item $p->ignore_tags( @tags ) + +Any C<start> and C<end> events involving any of the tags given are +suppressed. To reset the filter (i.e. don't suppress any C<start> and +C<end> events), call C<ignore_tags> without an argument. + +=item $p->report_tags( @tags ) + +Any C<start> and C<end> events involving any of the tags I<not> given +are suppressed. To reset the filter (i.e. report all C<start> and +C<end> events), call C<report_tags> without an argument. + +=back + +Internally, the system has two filter lists, one for C<report_tags> +and one for C<ignore_tags>, and both filters are applied. This +effectively gives C<ignore_tags> precedence over C<report_tags>. + +Examples: + + $p->ignore_tags(qw(style)); + $p->report_tags(qw(script style)); + +results in only C<script> events being reported. + +=head2 Argspec + +Argspec is a string containing a comma-separated list that describes +the information reported by the event. The following argspec +identifier names can be used: + +=over + +=item C<attr> + +Attr causes a reference to a hash of attribute name/value pairs to be +passed. + +Boolean attributes' values are either the value set by +$p->boolean_attribute_value, or the attribute name if no value has been +set by $p->boolean_attribute_value. + +This passes undef except for C<start> events. + +Unless C<xml_mode> or C<case_sensitive> is enabled, the attribute +names are forced to lower case. + +General entities are decoded in the attribute values and +one layer of matching quotes enclosing the attribute values is removed. + +The Unicode character set is assumed for entity decoding. With Perl +version 5.6 or earlier only the Latin-1 range is supported, and +entities for characters outside the range 0..255 are left unchanged. + +=item C<@attr> + +Basically the same as C<attr>, but keys and values are passed as +individual arguments and the original sequence of the attributes is +kept. The parameters passed will be the same as the @attr calculated +here: + + @attr = map { $_ => $attr->{$_} } @$attrseq; + +assuming $attr and $attrseq here are the hash and array passed as the +result of C<attr> and C<attrseq> argspecs. + +This passes no values for events besides C<start>. + +=item C<attrseq> + +Attrseq causes a reference to an array of attribute names to be +passed. This can be useful if you want to walk the C<attr> hash in +the original sequence. + +This passes undef except for C<start> events. + +Unless C<xml_mode> or C<case_sensitive> is enabled, the attribute +names are forced to lower case. + +=item C<column> + +Column causes the column number of the start of the event to be passed. +The first column on a line is 0. + +=item C<dtext> + +Dtext causes the decoded text to be passed. General entities are +automatically decoded unless the event was inside a CDATA section or +was between literal start and end tags (C<script>, C<style>, +C<xmp>, C<iframe>, C<title>, C<textarea> and C<plaintext>). + +The Unicode character set is assumed for entity decoding. With Perl +version 5.6 or earlier only the Latin-1 range is supported, and +entities for characters outside the range 0..255 are left unchanged. + +This passes undef except for C<text> events. + +=item C<event> + +Event causes the event name to be passed. + +The event name is one of C<text>, C<start>, C<end>, C<declaration>, +C<comment>, C<process>, C<start_document> or C<end_document>. + +=item C<is_cdata> + +Is_cdata causes a TRUE value to be passed if the event is inside a CDATA +section or between literal start and end tags (C<script>, +C<style>, C<xmp>, C<iframe>, C<title>, C<textarea> and C<plaintext>). + +if the flag is FALSE for a text event, then you should normally +either use C<dtext> or decode the entities yourself before the text is +processed further. + +=item C<length> + +Length causes the number of bytes of the source text of the event to +be passed. + +=item C<line> + +Line causes the line number of the start of the event to be passed. +The first line in the document is 1. Line counting doesn't start +until at least one handler requests this value to be reported. + +=item C<offset> + +Offset causes the byte position in the HTML document of the start of +the event to be passed. The first byte in the document has offset 0. + +=item C<offset_end> + +Offset_end causes the byte position in the HTML document of the end of +the event to be passed. This is the same as C<offset> + C<length>. + +=item C<self> + +Self causes the current object to be passed to the handler. If the +handler is a method, this must be the first element in the argspec. + +An alternative to passing self as an argspec is to register closures +that capture $self by themselves as handlers. Unfortunately this +creates circular references which prevent the HTML::Parser object +from being garbage collected. Using the C<self> argspec avoids this +problem. + +=item C<skipped_text> + +Skipped_text returns the concatenated text of all the events that have +been skipped since the last time an event was reported. Events might +be skipped because no handler is registered for them or because some +filter applies. Skipped text also includes marked section markup, +since there are no events that can catch it. + +If an C<"">-handler is registered for an event, then the text for this +event is not included in C<skipped_text>. Skipped text both before +and after the C<"">-event is included in the next reported +C<skipped_text>. + +=item C<tag> + +Same as C<tagname>, but prefixed with "/" if it belongs to an C<end> +event and "!" for a declaration. The C<tag> does not have any prefix +for C<start> events, and is in this case identical to C<tagname>. + +=item C<tagname> + +This is the element name (or I<generic identifier> in SGML jargon) for +start and end tags. Since HTML is case insensitive, this name is +forced to lower case to ease string matching. + +Since XML is case sensitive, the tagname case is not changed when +C<xml_mode> is enabled. The same happens if the C<case_sensitive> attribute +is set. + +The declaration type of declaration elements is also passed as a tagname, +even if that is a bit strange. +In fact, in the current implementation tagname is +identical to C<token0> except that the name may be forced to lower case. + +=item C<token0> + +Token0 causes the original text of the first token string to be +passed. This should always be the same as $tokens->[0]. + +For C<declaration> events, this is the declaration type. + +For C<start> and C<end> events, this is the tag name. + +For C<process> and non-strict C<comment> events, this is everything +inside the tag. + +This passes undef if there are no tokens in the event. + +=item C<tokenpos> + +Tokenpos causes a reference to an array of token positions to be +passed. For each string that appears in C<tokens>, this array +contains two numbers. The first number is the offset of the start of +the token in the original C<text> and the second number is the length +of the token. + +Boolean attributes in a C<start> event will have (0,0) for the +attribute value offset and length. + +This passes undef if there are no tokens in the event (e.g., C<text>) +and for artificial C<end> events triggered by empty element tags. + +If you are using these offsets and lengths to modify C<text>, you +should either work from right to left, or be very careful to calculate +the changes to the offsets. + +=item C<tokens> + +Tokens causes a reference to an array of token strings to be passed. +The strings are exactly as they were found in the original text, +no decoding or case changes are applied. + +For C<declaration> events, the array contains each word, comment, and +delimited string starting with the declaration type. + +For C<comment> events, this contains each sub-comment. If +$p->strict_comments is disabled, there will be only one sub-comment. + +For C<start> events, this contains the original tag name followed by +the attribute name/value pairs. The values of boolean attributes will +be either the value set by $p->boolean_attribute_value, or the +attribute name if no value has been set by +$p->boolean_attribute_value. + +For C<end> events, this contains the original tag name (always one token). + +For C<process> events, this contains the process instructions (always one +token). + +This passes C<undef> for C<text> events. + +=item C<text> + +Text causes the source text (including markup element delimiters) to be +passed. + +=item C<undef> + +Pass an undefined value. Useful as padding where the same handler +routine is registered for multiple events. + +=item C<'...'> + +A literal string of 0 to 255 characters enclosed +in single (') or double (") quotes is passed as entered. + +=back + +The whole argspec string can be wrapped up in C<'@{...}'> to signal +that the resulting event array should be flattened. This only makes a +difference if an array reference is used as the handler target. +Consider this example: + + $p->handler(text => [], 'text'); + $p->handler(text => [], '@{text}']); + +With two text events; C<"foo">, C<"bar">; then the first example will end +up with [["foo"], ["bar"]] and the second with ["foo", "bar"] in +the handler target array. + + +=head2 Events + +Handlers for the following events can be registered: + +=over + +=item C<comment> + +This event is triggered when a markup comment is recognized. + +Example: + + <!-- This is a comment -- -- So is this --> + +=item C<declaration> + +This event is triggered when a I<markup declaration> is recognized. + +For typical HTML documents, the only declaration you are +likely to find is <!DOCTYPE ...>. + +Example: + + <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" + "http://www.w3.org/TR/html40/strict.dtd"> + +DTDs inside <!DOCTYPE ...> will confuse HTML::Parser. + +=item C<default> + +This event is triggered for events that do not have a specific +handler. You can set up a handler for this event to catch stuff you +did not want to catch explicitly. + +=item C<end> + +This event is triggered when an end tag is recognized. + +Example: + + </A> + +=item C<end_document> + +This event is triggered when $p->eof is called and after any remaining +text is flushed. There is no document text associated with this event. + +=item C<process> + +This event is triggered when a processing instructions markup is +recognized. + +The format and content of processing instructions are system and +application dependent. + +Examples: + + <? HTML processing instructions > + <? XML processing instructions ?> + +=item C<start> + +This event is triggered when a start tag is recognized. + +Example: + + <A HREF="http://www.perl.com/"> + +=item C<start_document> + +This event is triggered before any other events for a new document. A +handler for it can be used to initialize stuff. There is no document +text associated with this event. + +=item C<text> + +This event is triggered when plain text (characters) is recognized. +The text may contain multiple lines. A sequence of text may be broken +between several text events unless $p->unbroken_text is enabled. + +The parser will make sure that it does not break a word or a sequence +of whitespace between two text events. + +=back + +=head2 Unicode + +The C<HTML::Parser> can parse Unicode strings when running under +perl-5.8 or better. If Unicode is passed to $p->parse() then chunks +of Unicode will be reported to the handlers. The offset and length +argspecs will also report their position in terms of characters. + +It is safe to parse raw undecoded UTF-8 if you either avoid decoding +entities and make sure to not use I<argspecs> that do, or enable the +C<utf8_mode> for the parser. Parsing of undecoded UTF-8 might be +useful when parsing from a file where you need the reported offsets +and lengths to match the byte offsets in the file. + +If a filename is passed to $p->parse_file() then the file will be read +in binary mode. This will be fine if the file contains only ASCII or +Latin-1 characters. If the file contains UTF-8 encoded text then care +must be taken when decoding entities as described in the previous +paragraph, but better is to open the file with the UTF-8 layer so that +it is decoded properly: + + open(my $fh, "<:utf8", "index.html") || die "...: $!"; + $p->parse_file($fh); + +If the file contains text encoded in a charset besides ASCII, Latin-1 +or UTF-8 then decoding will always be needed. + +=head1 VERSION 2 COMPATIBILITY + +When an C<HTML::Parser> object is constructed with no arguments, a set +of handlers is automatically provided that is compatible with the old +HTML::Parser version 2 callback methods. + +This is equivalent to the following method calls: + + $p->handler(start => "start", "self, tagname, attr, attrseq, text"); + $p->handler(end => "end", "self, tagname, text"); + $p->handler(text => "text", "self, text, is_cdata"); + $p->handler(process => "process", "self, token0, text"); + $p->handler(comment => + sub { + my($self, $tokens) = @_; + for (@$tokens) {$self->comment($_);}}, + "self, tokens"); + $p->handler(declaration => + sub { + my $self = shift; + $self->declaration(substr($_[0], 2, -1));}, + "self, text"); + +Setting up these handlers can also be requested with the "api_version => +2" constructor option. + +=head1 SUBCLASSING + +The C<HTML::Parser> class is subclassable. Parser objects are plain +hashes and C<HTML::Parser> reserves only hash keys that start with +"_hparser". The parser state can be set up by invoking the init() +method, which takes the same arguments as new(). + +=head1 EXAMPLES + +The first simple example shows how you might strip out comments from +an HTML document. We achieve this by setting up a comment handler that +does nothing and a default handler that will print out anything else: + + use HTML::Parser; + HTML::Parser->new(default_h => [sub { print shift }, 'text'], + comment_h => [""], + )->parse_file(shift || die) || die $!; + +An alternative implementation is: + + use HTML::Parser; + HTML::Parser->new(end_document_h => [sub { print shift }, + 'skipped_text'], + comment_h => [""], + )->parse_file(shift || die) || die $!; + +This will in most cases be much more efficient since only a single +callback will be made. + +The next example prints out the text that is inside the <title> +element of an HTML document. Here we start by setting up a start +handler. When it sees the title start tag it enables a text handler +that prints any text found and an end handler that will terminate +parsing as soon as the title end tag is seen: + + use HTML::Parser (); + + sub start_handler + { + return if shift ne "title"; + my $self = shift; + $self->handler(text => sub { print shift }, "dtext"); + $self->handler(end => sub { shift->eof if shift eq "title"; }, + "tagname,self"); + } + + my $p = HTML::Parser->new(api_version => 3); + $p->handler( start => \&start_handler, "tagname,self"); + $p->parse_file(shift || die) || die $!; + print "\n"; + +More examples are found in the F<eg/> directory of the C<HTML-Parser> +distribution: the program C<hrefsub> shows how you can edit all links +found in a document; the program C<htextsub> shows how to edit the text only; the +program C<hstrip> shows how you can strip out certain tags/elements +and/or attributes; and the program C<htext> show how to obtain the +plain text, but not any script/style content. + +You can browse the F<eg/> directory online from the I<[Browse]> link on +the http://search.cpan.org/~gaas/HTML-Parser/ page. + +=head1 BUGS + +The <style> and <script> sections do not end with the first "</", but +need the complete corresponding end tag. The standard behaviour is +not really practical. + +When the I<strict_comment> option is enabled, we still recognize +comments where there is something other than whitespace between even +and odd "--" markers. + +Once $p->boolean_attribute_value has been set, there is no way to +restore the default behaviour. + +There is currently no way to get both quote characters +into the same literal argspec. + +Empty tags, e.g. "<>" and "</>", are not recognized. SGML allows them +to repeat the previous start tag or close the previous start tag +respectively. + +NET tags, e.g. "code/.../" are not recognized. This is SGML +shorthand for "<code>...</code>". + +Unclosed start or end tags, e.g. "<tt<b>...</b</tt>" are not +recognized. + +=head1 DIAGNOSTICS + +The following messages may be produced by HTML::Parser. The notation +in this listing is the same as used in L<perldiag>: + +=over + +=item Not a reference to a hash + +(F) The object blessed into or subclassed from HTML::Parser is not a +hash as required by the HTML::Parser methods. + +=item Bad signature in parser state object at %p + +(F) The _hparser_xs_state element does not refer to a valid state structure. +Something must have changed the internal value +stored in this hash element, or the memory has been overwritten. + +=item _hparser_xs_state element is not a reference + +(F) The _hparser_xs_state element has been destroyed. + +=item Can't find '_hparser_xs_state' element in HTML::Parser hash + +(F) The _hparser_xs_state element is missing from the parser hash. +It was either deleted, or not created when the object was created. + +=item API version %s not supported by HTML::Parser %s + +(F) The constructor option 'api_version' with an argument greater than +or equal to 4 is reserved for future extensions. + +=item Bad constructor option '%s' + +(F) An unknown constructor option key was passed to the new() or +init() methods. + +=item Parse loop not allowed + +(F) A handler invoked the parse() or parse_file() method. +This is not permitted. + +=item marked sections not supported + +(F) The $p->marked_sections() method was invoked in a HTML::Parser +module that was compiled without support for marked sections. + +=item Unknown boolean attribute (%d) + +(F) Something is wrong with the internal logic that set up aliases for +boolean attributes. + +=item Only code or array references allowed as handler + +(F) The second argument for $p->handler must be either a subroutine +reference, then name of a subroutine or method, or a reference to an +array. + +=item No handler for %s events + +(F) The first argument to $p->handler must be a valid event name; i.e. one +of "start", "end", "text", "process", "declaration" or "comment". + +=item Unrecognized identifier %s in argspec + +(F) The identifier is not a known argspec name. +Use one of the names mentioned in the argspec section above. + +=item Literal string is longer than 255 chars in argspec + +(F) The current implementation limits the length of literals in +an argspec to 255 characters. Make the literal shorter. + +=item Backslash reserved for literal string in argspec + +(F) The backslash character "\" is not allowed in argspec literals. +It is reserved to permit quoting inside a literal in a later version. + +=item Unterminated literal string in argspec + +(F) The terminating quote character for a literal was not found. + +=item Bad argspec (%s) + +(F) Only identifier names, literals, spaces and commas +are allowed in argspecs. + +=item Missing comma separator in argspec + +(F) Identifiers in an argspec must be separated with ",". + +=item Parsing of undecoded UTF-8 will give garbage when decoding entities + +(W) The first chunk parsed appears to contain undecoded UTF-8 and one +or more argspecs that decode entities are used for the callback +handlers. + +The result of decoding will be a mix of encoded and decoded characters +for any entities that expand to characters with code above 127. This +is not a good thing. + +The solution is to use the Encode::encode_utf8() on the data before +feeding it to the $p->parse(). For $p->parse_file() pass a file that +has been opened in ":utf8" mode. + +The parser can process raw undecoded UTF-8 sanely if the C<utf8_mode> +is enabled or if the "attr", "@attr" or "dtext" argspecs is avoided. + +=item Parsing string decoded with wrong endianness + +(W) The first character in the document is U+FFFE. This is not a +legal Unicode character but a byte swapped BOM. The result of parsing +will likely be garbage. + +=item Parsing of undecoded UTF-32 + +(W) The parser found the Unicode UTF-32 BOM signature at the start +of the document. The result of parsing will likely be garbage. + +=item Parsing of undecoded UTF-16 + +(W) The parser found the Unicode UTF-16 BOM signature at the start of +the document. The result of parsing will likely be garbage. + +=back + +=head1 SEE ALSO + +L<HTML::Entities>, L<HTML::PullParser>, L<HTML::TokeParser>, L<HTML::HeadParser>, +L<HTML::LinkExtor>, L<HTML::Form> + +L<HTML::TreeBuilder> (part of the I<HTML-Tree> distribution) + +http://www.w3.org/TR/html4 + +More information about marked sections and processing instructions may +be found at C<http://www.sgml.u-net.com/book/sgml-8.htm>. + +=head1 COPYRIGHT + + Copyright 1996-2008 Gisle Aas. All rights reserved. + Copyright 1999-2000 Michael A. Chase. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/HTML/PullParser.pm b/Master/tlpkg/tlperl/lib/HTML/PullParser.pm new file mode 100755 index 00000000000..30833793251 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/PullParser.pm @@ -0,0 +1,209 @@ +package HTML::PullParser; + +require HTML::Parser; +@ISA=qw(HTML::Parser); +$VERSION = "3.57"; + +use strict; +use Carp (); + +sub new +{ + my($class, %cnf) = @_; + + # Construct argspecs for the various events + my %argspec; + for (qw(start end text declaration comment process default)) { + my $tmp = delete $cnf{$_}; + next unless defined $tmp; + $argspec{$_} = $tmp; + } + Carp::croak("Info not collected for any events") + unless %argspec; + + my $file = delete $cnf{file}; + my $doc = delete $cnf{doc}; + Carp::croak("Can't parse from both 'doc' and 'file' at the same time") + if defined($file) && defined($doc); + Carp::croak("No 'doc' or 'file' given to parse from") + unless defined($file) || defined($doc); + + # Create object + $cnf{api_version} = 3; + my $self = $class->SUPER::new(%cnf); + + my $accum = $self->{pullparser_accum} = []; + while (my($event, $argspec) = each %argspec) { + $self->SUPER::handler($event => $accum, $argspec); + } + + if (defined $doc) { + $self->{pullparser_str_ref} = ref($doc) ? $doc : \$doc; + $self->{pullparser_str_pos} = 0; + } + else { + if (!ref($file) && ref(\$file) ne "GLOB") { + require IO::File; + $file = IO::File->new($file, "r") || return; + } + + $self->{pullparser_file} = $file; + } + $self; +} + + +sub handler +{ + Carp::croak("Can't set handlers for HTML::PullParser"); +} + + +sub get_token +{ + my $self = shift; + while (!@{$self->{pullparser_accum}} && !$self->{pullparser_eof}) { + if (my $f = $self->{pullparser_file}) { + # must try to parse more from the file + my $buf; + if (read($f, $buf, 512)) { + $self->parse($buf); + } else { + $self->eof; + $self->{pullparser_eof}++; + delete $self->{pullparser_file}; + } + } + elsif (my $sref = $self->{pullparser_str_ref}) { + # must try to parse more from the scalar + my $pos = $self->{pullparser_str_pos}; + my $chunk = substr($$sref, $pos, 512); + $self->parse($chunk); + $pos += length($chunk); + if ($pos < length($$sref)) { + $self->{pullparser_str_pos} = $pos; + } + else { + $self->eof; + $self->{pullparser_eof}++; + delete $self->{pullparser_str_ref}; + delete $self->{pullparser_str_pos}; + } + } + else { + die; + } + } + shift @{$self->{pullparser_accum}}; +} + + +sub unget_token +{ + my $self = shift; + unshift @{$self->{pullparser_accum}}, @_; + $self; +} + +1; + + +__END__ + +=head1 NAME + +HTML::PullParser - Alternative HTML::Parser interface + +=head1 SYNOPSIS + + use HTML::PullParser; + + $p = HTML::PullParser->new(file => "index.html", + start => 'event, tagname, @attr', + end => 'event, tagname', + ignore_elements => [qw(script style)], + ) || die "Can't open: $!"; + while (my $token = $p->get_token) { + #...do something with $token + } + +=head1 DESCRIPTION + +The HTML::PullParser is an alternative interface to the HTML::Parser class. +It basically turns the HTML::Parser inside out. You associate a file +(or any IO::Handle object or string) with the parser at construction time and +then repeatedly call $parser->get_token to obtain the tags and text +found in the parsed document. + +The following methods are provided: + +=over 4 + +=item $p = HTML::PullParser->new( file => $file, %options ) + +=item $p = HTML::PullParser->new( doc => \$doc, %options ) + +A C<HTML::PullParser> can be made to parse from either a file or a +literal document based on whether the C<file> or C<doc> option is +passed to the parser's constructor. + +The C<file> passed in can either be a file name or a file handle +object. If a file name is passed, and it can't be opened for reading, +then the constructor will return an undefined value and $! will tell +you why it failed. Otherwise the argument is taken to be some object +that the C<HTML::PullParser> can read() from when it needs more data. +The stream will be read() until EOF, but not closed. + +A C<doc> can be passed plain or as a reference +to a scalar. If a reference is passed then the value of this scalar +should not be changed before all tokens have been extracted. + +Next the information to be returned for the different token types must +be set up. This is done by simply associating an argspec (as defined +in L<HTML::Parser>) with the events you have an interest in. For +instance, if you want C<start> tokens to be reported as the string +C<'S'> followed by the tagname and the attributes you might pass an +C<start>-option like this: + + $p = HTML::PullParser->new( + doc => $document_to_parse, + start => '"S", tagname, @attr', + end => '"E", tagname', + ); + +At last other C<HTML::Parser> options, like C<ignore_tags>, and +C<unbroken_text>, can be passed in. Note that you should not use the +I<event>_h options to set up parser handlers. That would confuse the +inner logic of C<HTML::PullParser>. + +=item $token = $p->get_token + +This method will return the next I<token> found in the HTML document, +or C<undef> at the end of the document. The token is returned as an +array reference. The content of this array match the argspec set up +during C<HTML::PullParser> construction. + +=item $p->unget_token( @tokens ) + +If you find out you have read too many tokens you can push them back, +so that they are returned again the next time $p->get_token is called. + +=back + +=head1 EXAMPLES + +The 'eg/hform' script shows how we might parse the form section of +HTML::Documents using HTML::PullParser. + +=head1 SEE ALSO + +L<HTML::Parser>, L<HTML::TokeParser> + +=head1 COPYRIGHT + +Copyright 1998-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/HTML/Tagset.pm b/Master/tlpkg/tlperl/lib/HTML/Tagset.pm new file mode 100755 index 00000000000..754137fd6fe --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/Tagset.pm @@ -0,0 +1,471 @@ +package HTML::Tagset; + +use strict; + +=head1 NAME + +HTML::Tagset - data tables useful in parsing HTML + +=head1 VERSION + +Version 3.20 + +=cut + +use vars qw( $VERSION ); + +$VERSION = '3.20'; + +=head1 SYNOPSIS + + use HTML::Tagset; + # Then use any of the items in the HTML::Tagset package + # as need arises + +=head1 DESCRIPTION + +This module contains several data tables useful in various kinds of +HTML parsing operations. + +Note that all tag names used are lowercase. + +In the following documentation, a "hashset" is a hash being used as a +set -- the hash conveys that its keys are there, and the actual values +associated with the keys are not significant. (But what values are +there, are always true.) + +=cut + +use vars qw( + $VERSION + %emptyElement %optionalEndTag %linkElements %boolean_attr + %isHeadElement %isBodyElement %isPhraseMarkup + %is_Possible_Strict_P_Content + %isHeadOrBodyElement + %isList %isTableElement %isFormElement + %isKnown %canTighten + @p_closure_barriers + %isCDATA_Parent +); + +=head1 VARIABLES + +Note that none of these variables are exported. + +=head2 hashset %HTML::Tagset::emptyElement + +This hashset has as values the tag-names (GIs) of elements that cannot +have content. (For example, "base", "br", "hr".) So +C<$HTML::Tagset::emptyElement{'hr'}> exists and is true. +C<$HTML::Tagset::emptyElement{'dl'}> does not exist, and so is not true. + +=cut + +%emptyElement = map {; $_ => 1 } qw(base link meta isindex + img br hr wbr + input area param + embed bgsound spacer + basefont col frame + ~comment ~literal + ~declaration ~pi + ); +# The "~"-initial names are for pseudo-elements used by HTML::Entities +# and TreeBuilder + +=head2 hashset %HTML::Tagset::optionalEndTag + +This hashset lists tag-names for elements that can have content, but whose +end-tags are generally, "safely", omissible. Example: +C<$HTML::Tagset::emptyElement{'li'}> exists and is true. + +=cut + +%optionalEndTag = map {; $_ => 1 } qw(p li dt dd); # option th tr td); + +=head2 hash %HTML::Tagset::linkElements + +Values in this hash are tagnames for elements that might contain +links, and the value for each is a reference to an array of the names +of attributes whose values can be links. + +=cut + +%linkElements = +( + 'a' => ['href'], + 'applet' => ['archive', 'codebase', 'code'], + 'area' => ['href'], + 'base' => ['href'], + 'bgsound' => ['src'], + 'blockquote' => ['cite'], + 'body' => ['background'], + 'del' => ['cite'], + 'embed' => ['pluginspage', 'src'], + 'form' => ['action'], + 'frame' => ['src', 'longdesc'], + 'iframe' => ['src', 'longdesc'], + 'ilayer' => ['background'], + 'img' => ['src', 'lowsrc', 'longdesc', 'usemap'], + 'input' => ['src', 'usemap'], + 'ins' => ['cite'], + 'isindex' => ['action'], + 'head' => ['profile'], + 'layer' => ['background', 'src'], + 'link' => ['href'], + 'object' => ['classid', 'codebase', 'data', 'archive', 'usemap'], + 'q' => ['cite'], + 'script' => ['src', 'for'], + 'table' => ['background'], + 'td' => ['background'], + 'th' => ['background'], + 'tr' => ['background'], + 'xmp' => ['href'], +); + +=head2 hash %HTML::Tagset::boolean_attr + +This hash (not hashset) lists what attributes of what elements can be +printed without showing the value (for example, the "noshade" attribute +of "hr" elements). For elements with only one such attribute, its value +is simply that attribute name. For elements with many such attributes, +the value is a reference to a hashset containing all such attributes. + +=cut + +%boolean_attr = ( +# TODO: make these all hashes + 'area' => 'nohref', + 'dir' => 'compact', + 'dl' => 'compact', + 'hr' => 'noshade', + 'img' => 'ismap', + 'input' => { 'checked' => 1, 'readonly' => 1, 'disabled' => 1 }, + 'menu' => 'compact', + 'ol' => 'compact', + 'option' => 'selected', + 'select' => 'multiple', + 'td' => 'nowrap', + 'th' => 'nowrap', + 'ul' => 'compact', +); + +#========================================================================== +# List of all elements from Extensible HTML version 1.0 Transitional DTD: +# +# a abbr acronym address applet area b base basefont bdo big +# blockquote body br button caption center cite code col colgroup +# dd del dfn dir div dl dt em fieldset font form h1 h2 h3 h4 h5 h6 +# head hr html i iframe img input ins isindex kbd label legend li +# link map menu meta noframes noscript object ol optgroup option p +# param pre q s samp script select small span strike strong style +# sub sup table tbody td textarea tfoot th thead title tr tt u ul +# var +# +# Varia from Mozilla source internal table of tags: +# Implemented: +# xmp listing wbr nobr frame frameset noframes ilayer +# layer nolayer spacer embed multicol +# But these are unimplemented: +# sound?? keygen?? server?? +# Also seen here and there: +# marquee?? app?? (both unimplemented) +#========================================================================== + +=head2 hashset %HTML::Tagset::isPhraseMarkup + +This hashset contains all phrasal-level elements. + +=cut + +%isPhraseMarkup = map {; $_ => 1 } qw( + span abbr acronym q sub sup + cite code em kbd samp strong var dfn strike + b i u s tt small big + a img br + wbr nobr blink + font basefont bdo + spacer embed noembed +); # had: center, hr, table + + +=head2 hashset %HTML::Tagset::is_Possible_Strict_P_Content + +This hashset contains all phrasal-level elements that be content of a +P element, for a strict model of HTML. + +=cut + +%is_Possible_Strict_P_Content = ( + %isPhraseMarkup, + %isFormElement, + map {; $_ => 1} qw( object script map ) + # I've no idea why there's these latter exceptions. + # I'm just following the HTML4.01 DTD. +); + +#from html4 strict: +#<!ENTITY % fontstyle "TT | I | B | BIG | SMALL"> +# +#<!ENTITY % phrase "EM | STRONG | DFN | CODE | +# SAMP | KBD | VAR | CITE | ABBR | ACRONYM" > +# +#<!ENTITY % special +# "A | IMG | OBJECT | BR | SCRIPT | MAP | Q | SUB | SUP | SPAN | BDO"> +# +#<!ENTITY % formctrl "INPUT | SELECT | TEXTAREA | LABEL | BUTTON"> +# +#<!-- %inline; covers inline or "text-level" elements --> +#<!ENTITY % inline "#PCDATA | %fontstyle; | %phrase; | %special; | %formctrl;"> + +=head2 hashset %HTML::Tagset::isHeadElement + +This hashset contains all elements that elements that should be +present only in the 'head' element of an HTML document. + +=cut + +%isHeadElement = map {; $_ => 1 } + qw(title base link meta isindex script style object bgsound); + +=head2 hashset %HTML::Tagset::isList + +This hashset contains all elements that can contain "li" elements. + +=cut + +%isList = map {; $_ => 1 } qw(ul ol dir menu); + +=head2 hashset %HTML::Tagset::isTableElement + +This hashset contains all elements that are to be found only in/under +a "table" element. + +=cut + +%isTableElement = map {; $_ => 1 } + qw(tr td th thead tbody tfoot caption col colgroup); + +=head2 hashset %HTML::Tagset::isFormElement + +This hashset contains all elements that are to be found only in/under +a "form" element. + +=cut + +%isFormElement = map {; $_ => 1 } + qw(input select option optgroup textarea button label); + +=head2 hashset %HTML::Tagset::isBodyMarkup + +This hashset contains all elements that are to be found only in/under +the "body" element of an HTML document. + +=cut + +%isBodyElement = map {; $_ => 1 } qw( + h1 h2 h3 h4 h5 h6 + p div pre plaintext address blockquote + xmp listing + center + + multicol + iframe ilayer nolayer + bgsound + + hr + ol ul dir menu li + dl dt dd + ins del + + fieldset legend + + map area + applet param object + isindex script noscript + table + center + form + ), + keys %isFormElement, + keys %isPhraseMarkup, # And everything phrasal + keys %isTableElement, +; + + +=head2 hashset %HTML::Tagset::isHeadOrBodyElement + +This hashset includes all elements that I notice can fall either in +the head or in the body. + +=cut + +%isHeadOrBodyElement = map {; $_ => 1 } + qw(script isindex style object map area param noscript bgsound); + # i.e., if we find 'script' in the 'body' or the 'head', don't freak out. + + +=head2 hashset %HTML::Tagset::isKnown + +This hashset lists all known HTML elements. + +=cut + +%isKnown = (%isHeadElement, %isBodyElement, + map{; $_=>1 } + qw( head body html + frame frameset noframes + ~comment ~pi ~directive ~literal +)); + # that should be all known tags ever ever + + +=head2 hashset %HTML::Tagset::canTighten + +This hashset lists elements that might have ignorable whitespace as +children or siblings. + +=cut + +%canTighten = %isKnown; +delete @canTighten{ + keys(%isPhraseMarkup), 'input', 'select', + 'xmp', 'listing', 'plaintext', 'pre', +}; + # xmp, listing, plaintext, and pre are untightenable, and + # in a really special way. +@canTighten{'hr','br'} = (1,1); + # exceptional 'phrasal' things that ARE subject to tightening. + +# The one case where I can think of my tightening rules failing is: +# <p>foo bar<center> <em>baz quux</em> ... +# ^-- that would get deleted. +# But that's pretty gruesome code anyhow. You gets what you pays for. + +#========================================================================== + +=head2 array @HTML::Tagset::p_closure_barriers + +This array has a meaning that I have only seen a need for in +C<HTML::TreeBuilder>, but I include it here on the off chance that someone +might find it of use: + +When we see a "E<lt>pE<gt>" token, we go lookup up the lineage for a p +element we might have to minimize. At first sight, we might say that +if there's a p anywhere in the lineage of this new p, it should be +closed. But that's wrong. Consider this document: + + <html> + <head> + <title>foo</title> + </head> + <body> + <p>foo + <table> + <tr> + <td> + foo + <p>bar + </td> + </tr> + </table> + </p> + </body> + </html> + +The second p is quite legally inside a much higher p. + +My formalization of the reason why this is legal, but this: + + <p>foo<p>bar</p></p> + +isn't, is that something about the table constitutes a "barrier" to +the application of the rule about what p must minimize. + +So C<@HTML::Tagset::p_closure_barriers> is the list of all such +barrier-tags. + +=cut + +@p_closure_barriers = qw( + li blockquote + ul ol menu dir + dl dt dd + td th tr table caption + div + ); + +# In an ideal world (i.e., XHTML) we wouldn't have to bother with any of this +# monkey business of barriers to minimization! + +=head2 hashset %isCDATA_Parent + +This hashset includes all elements whose content is CDATA. + +=cut + +%isCDATA_Parent = map {; $_ => 1 } + qw(script style xmp listing plaintext); + +# TODO: there's nothing else that takes CDATA children, right? + +# As the HTML3 DTD (Raggett 1995-04-24) noted: +# The XMP, LISTING and PLAINTEXT tags are incompatible with SGML +# and derive from very early versions of HTML. They require non- +# standard parsers and will cause problems for processing +# documents with standard SGML tools. + + +=head1 CAVEATS + +You may find it useful to alter the behavior of modules (like +C<HTML::Element> or C<HTML::TreeBuilder>) that use C<HTML::Tagset>'s +data tables by altering the data tables themselves. You are welcome +to try, but be careful; and be aware that different modules may or may +react differently to the data tables being changed. + +Note that it may be inappropriate to use these tables for I<producing> +HTML -- for example, C<%isHeadOrBodyElement> lists the tagnames +for all elements that can appear either in the head or in the body, +such as "script". That doesn't mean that I am saying your code that +produces HTML should feel free to put script elements in either place! +If you are producing programs that spit out HTML, you should be +I<intimately> familiar with the DTDs for HTML or XHTML (available at +C<http://www.w3.org/>), and you should slavishly obey them, not +the data tables in this document. + +=head1 SEE ALSO + +L<HTML::Element>, L<HTML::TreeBuilder>, L<HTML::LinkExtor> + +=head1 COPYRIGHT & LICENSE + +Copyright 1995-2000 Gisle Aas. + +Copyright 2000-2005 Sean M. Burke. + +Copyright 2005-2008 Andy Lester. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 ACKNOWLEDGEMENTS + +Most of the code/data in this module was adapted from code written +by Gisle Aas for C<HTML::Element>, C<HTML::TreeBuilder>, and +C<HTML::LinkExtor>. Then it was maintained by Sean M. Burke. + +=head1 AUTHOR + +Current maintainer: Andy Lester, C<< <andy at petdance.com> >> + +=head1 BUGS + +Please report any bugs or feature requests to +C<bug-html-tagset at rt.cpan.org>, or through the web interface at +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=HTML-Tagset>. I will +be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/HTML/TokeParser.pm b/Master/tlpkg/tlperl/lib/HTML/TokeParser.pm new file mode 100755 index 00000000000..94128dbef75 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/TokeParser.pm @@ -0,0 +1,369 @@ +package HTML::TokeParser; + +require HTML::PullParser; +@ISA=qw(HTML::PullParser); +$VERSION = "3.57"; + +use strict; +use Carp (); +use HTML::Entities qw(decode_entities); +use HTML::Tagset (); + +my %ARGS = +( + start => "'S',tagname,attr,attrseq,text", + end => "'E',tagname,text", + text => "'T',text,is_cdata", + process => "'PI',token0,text", + comment => "'C',text", + declaration => "'D',text", + + # options that default on + unbroken_text => 1, +); + + +sub new +{ + my $class = shift; + my %cnf; + if (@_ == 1) { + my $type = (ref($_[0]) eq "SCALAR") ? "doc" : "file"; + %cnf = ($type => $_[0]); + } + else { + %cnf = @_; + } + + my $textify = delete $cnf{textify} || {img => "alt", applet => "alt"}; + + my $self = $class->SUPER::new(%cnf, %ARGS) || return undef; + + $self->{textify} = $textify; + $self; +} + + +sub get_tag +{ + my $self = shift; + my $token; + while (1) { + $token = $self->get_token || return undef; + my $type = shift @$token; + next unless $type eq "S" || $type eq "E"; + substr($token->[0], 0, 0) = "/" if $type eq "E"; + return $token unless @_; + for (@_) { + return $token if $token->[0] eq $_; + } + } +} + + +sub _textify { + my($self, $token) = @_; + my $tag = $token->[1]; + return undef unless exists $self->{textify}{$tag}; + + my $alt = $self->{textify}{$tag}; + my $text; + if (ref($alt)) { + $text = &$alt(@$token); + } else { + $text = $token->[2]{$alt || "alt"}; + $text = "[\U$tag]" unless defined $text; + } + return $text; +} + + +sub get_text +{ + my $self = shift; + my @text; + while (my $token = $self->get_token) { + my $type = $token->[0]; + if ($type eq "T") { + my $text = $token->[1]; + decode_entities($text) unless $token->[2]; + push(@text, $text); + } elsif ($type =~ /^[SE]$/) { + my $tag = $token->[1]; + if ($type eq "S") { + if (defined(my $text = _textify($self, $token))) { + push(@text, $text); + next; + } + } else { + $tag = "/$tag"; + } + if (!@_ || grep $_ eq $tag, @_) { + $self->unget_token($token); + last; + } + push(@text, " ") + if $tag eq "br" || !$HTML::Tagset::isPhraseMarkup{$token->[1]}; + } + } + join("", @text); +} + + +sub get_trimmed_text +{ + my $self = shift; + my $text = $self->get_text(@_); + $text =~ s/^\s+//; $text =~ s/\s+$//; $text =~ s/\s+/ /g; + $text; +} + +sub get_phrase { + my $self = shift; + my @text; + while (my $token = $self->get_token) { + my $type = $token->[0]; + if ($type eq "T") { + my $text = $token->[1]; + decode_entities($text) unless $token->[2]; + push(@text, $text); + } elsif ($type =~ /^[SE]$/) { + my $tag = $token->[1]; + if ($type eq "S") { + if (defined(my $text = _textify($self, $token))) { + push(@text, $text); + next; + } + } + if (!$HTML::Tagset::isPhraseMarkup{$tag}) { + $self->unget_token($token); + last; + } + push(@text, " ") if $tag eq "br"; + } + } + my $text = join("", @text); + $text =~ s/^\s+//; $text =~ s/\s+$//; $text =~ s/\s+/ /g; + $text; +} + +1; + + +__END__ + +=head1 NAME + +HTML::TokeParser - Alternative HTML::Parser interface + +=head1 SYNOPSIS + + require HTML::TokeParser; + $p = HTML::TokeParser->new("index.html") || + die "Can't open: $!"; + $p->empty_element_tags(1); # configure its behaviour + + while (my $token = $p->get_token) { + #... + } + +=head1 DESCRIPTION + +The C<HTML::TokeParser> is an alternative interface to the +C<HTML::Parser> class. It is an C<HTML::PullParser> subclass with a +predeclared set of token types. If you wish the tokens to be reported +differently you probably want to use the C<HTML::PullParser> directly. + +The following methods are available: + +=over 4 + +=item $p = HTML::TokeParser->new( $filename, %opt ); + +=item $p = HTML::TokeParser->new( $filehandle, %opt ); + +=item $p = HTML::TokeParser->new( \$document, %opt ); + +The object constructor argument is either a file name, a file handle +object, or the complete document to be parsed. Extra options can be +provided as key/value pairs and are processed as documented by the base +classes. + +If the argument is a plain scalar, then it is taken as the name of a +file to be opened and parsed. If the file can't be opened for +reading, then the constructor will return C<undef> and $! will tell +you why it failed. + +If the argument is a reference to a plain scalar, then this scalar is +taken to be the literal document to parse. The value of this +scalar should not be changed before all tokens have been extracted. + +Otherwise the argument is taken to be some object that the +C<HTML::TokeParser> can read() from when it needs more data. Typically +it will be a filehandle of some kind. The stream will be read() until +EOF, but not closed. + +A newly constructed C<HTML::TokeParser> differ from its base classes +by having the C<unbroken_text> attribute enabled by default. See +L<HTML::Parser> for a description of this and other attributes that +influence how the document is parsed. It is often a good idea to enable +C<empty_element_tags> behaviour. + +Note that the parsing result will likely not be valid if raw undecoded +UTF-8 is used as a source. When parsing UTF-8 encoded files turn +on UTF-8 decoding: + + open(my $fh, "<:utf8", "index.html") || die "Can't open 'index.html': $!"; + my $p = HTML::TokeParser->new( $fh ); + # ... + +If a $filename is passed to the constructor the file will be opened in +raw mode and the parsing result will only be valid if its content is +Latin-1 or pure ASCII. + +If parsing from an UTF-8 encoded string buffer decode it first: + + utf8::decode($document); + my $p = HTML::TokeParser->new( \$document ); + # ... + +=item $p->get_token + +This method will return the next I<token> found in the HTML document, +or C<undef> at the end of the document. The token is returned as an +array reference. The first element of the array will be a string +denoting the type of this token: "S" for start tag, "E" for end tag, +"T" for text, "C" for comment, "D" for declaration, and "PI" for +process instructions. The rest of the token array depend on the type +like this: + + ["S", $tag, $attr, $attrseq, $text] + ["E", $tag, $text] + ["T", $text, $is_data] + ["C", $text] + ["D", $text] + ["PI", $token0, $text] + +where $attr is a hash reference, $attrseq is an array reference and +the rest are plain scalars. The L<HTML::Parser/Argspec> explains the +details. + +=item $p->unget_token( @tokens ) + +If you find you have read too many tokens you can push them back, +so that they are returned the next time $p->get_token is called. + +=item $p->get_tag + +=item $p->get_tag( @tags ) + +This method returns the next start or end tag (skipping any other +tokens), or C<undef> if there are no more tags in the document. If +one or more arguments are given, then we skip tokens until one of the +specified tag types is found. For example: + + $p->get_tag("font", "/font"); + +will find the next start or end tag for a font-element. + +The tag information is returned as an array reference in the same form +as for $p->get_token above, but the type code (first element) is +missing. A start tag will be returned like this: + + [$tag, $attr, $attrseq, $text] + +The tagname of end tags are prefixed with "/", i.e. end tag is +returned like this: + + ["/$tag", $text] + +=item $p->get_text + +=item $p->get_text( @endtags ) + +This method returns all text found at the current position. It will +return a zero length string if the next token is not text. Any +entities will be converted to their corresponding character. + +If one or more arguments are given, then we return all text occurring +before the first of the specified tags found. For example: + + $p->get_text("p", "br"); + +will return the text up to either a paragraph of linebreak element. + +The text might span tags that should be I<textified>. This is +controlled by the $p->{textify} attribute, which is a hash that +defines how certain tags can be treated as text. If the name of a +start tag matches a key in this hash then this tag is converted to +text. The hash value is used to specify which tag attribute to obtain +the text from. If this tag attribute is missing, then the upper case +name of the tag enclosed in brackets is returned, e.g. "[IMG]". The +hash value can also be a subroutine reference. In this case the +routine is called with the start tag token content as its argument and +the return value is treated as the text. + +The default $p->{textify} value is: + + {img => "alt", applet => "alt"} + +This means that <IMG> and <APPLET> tags are treated as text, and that +the text to substitute can be found in the ALT attribute. + +=item $p->get_trimmed_text + +=item $p->get_trimmed_text( @endtags ) + +Same as $p->get_text above, but will collapse any sequences of white +space to a single space character. Leading and trailing white space is +removed. + +=item $p->get_phrase + +This will return all text found at the current position ignoring any +phrasal-level tags. Text is extracted until the first non +phrasal-level tag. Textification of tags is the same as for +get_text(). This method will collapse white space in the same way as +get_trimmed_text() does. + +The definition of <i>phrasal-level tags</i> is obtained from the +HTML::Tagset module. + +=back + +=head1 EXAMPLES + +This example extracts all links from a document. It will print one +line for each link, containing the URL and the textual description +between the <A>...</A> tags: + + use HTML::TokeParser; + $p = HTML::TokeParser->new(shift||"index.html"); + + while (my $token = $p->get_tag("a")) { + my $url = $token->[1]{href} || "-"; + my $text = $p->get_trimmed_text("/a"); + print "$url\t$text\n"; + } + +This example extract the <TITLE> from the document: + + use HTML::TokeParser; + $p = HTML::TokeParser->new(shift||"index.html"); + if ($p->get_tag("title")) { + my $title = $p->get_trimmed_text; + print "Title: $title\n"; + } + +=head1 SEE ALSO + +L<HTML::PullParser>, L<HTML::Parser> + +=head1 COPYRIGHT + +Copyright 1998-2005 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut |