diff options
Diffstat (limited to 'Master/tlpkg/tlperl')
122 files changed, 28840 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Bundle/LWP.pm b/Master/tlpkg/tlperl/lib/Bundle/LWP.pm new file mode 100644 index 00000000000..1f2f0454cc6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Bundle/LWP.pm @@ -0,0 +1,44 @@ +package Bundle::LWP; + +$VERSION = "5.835"; + +1; + +__END__ + +=head1 NAME + +Bundle::LWP - install all libwww-perl related modules + +=head1 SYNOPSIS + + perl -MCPAN -e 'install Bundle::LWP' + +=head1 CONTENTS + +MIME::Base64 - Used in authentication headers + +Digest::MD5 - Needed to do Digest authentication + +URI 1.10 - There are URIs everywhere + +Net::FTP 2.58 - If you want ftp://-support + +HTML::Tagset - Needed by HTML::Parser + +HTML::Parser - Needed by HTML::HeadParser + +HTML::HeadParser - To get the correct $res->base + +LWP - The reason why you need the modules above + +=head1 DESCRIPTION + +This bundle defines all prerequisite modules for libwww-perl. Bundles +have special meaning for the CPAN module. When you install the bundle +module all modules mentioned in L</CONTENTS> will be installed +instead. + +=head1 SEE ALSO + +L<CPAN/Bundles> diff --git a/Master/tlpkg/tlperl/lib/File/Listing.pm b/Master/tlpkg/tlperl/lib/File/Listing.pm new file mode 100644 index 00000000000..53a6ddc66be --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Listing.pm @@ -0,0 +1,412 @@ +package File::Listing; + +sub Version { $VERSION; } +$VERSION = "5.837"; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(parse_dir); + +use strict; + +use Carp (); +use HTTP::Date qw(str2time); + + + +sub parse_dir ($;$$$) +{ + my($dir, $tz, $fstype, $error) = @_; + + $fstype ||= 'unix'; + $fstype = "File::Listing::" . lc $fstype; + + my @args = $_[0]; + push(@args, $tz) if(@_ >= 2); + push(@args, $error) if(@_ >= 4); + + $fstype->parse(@args); +} + + +sub line { Carp::croak("Not implemented yet"); } +sub init { } # Dummy sub + + +sub file_mode ($) +{ + # This routine was originally borrowed from Graham Barr's + # Net::FTP package. + + local $_ = shift; + my $mode = 0; + my($type,$ch); + + s/^(.)// and $type = $1; + + while (/(.)/g) { + $mode <<= 1; + $mode |= 1 if $1 ne "-" && + $1 ne 'S' && + $1 ne 't' && + $1 ne 'T'; + } + + $type eq "d" and $mode |= 0040000 or # Directory + $type eq "l" and $mode |= 0120000 or # Symbolic Link + $mode |= 0100000; # Regular File + + $mode |= 0004000 if /^...s....../i; + $mode |= 0002000 if /^......s.../i; + $mode |= 0001000 if /^.........t/i; + + $mode; +} + + +sub parse +{ + my($pkg, $dir, $tz, $error) = @_; + + # First let's try to determine what kind of dir parameter we have + # received. We allow both listings, reference to arrays and + # file handles to read from. + + if (ref($dir) eq 'ARRAY') { + # Already splitted up + } + elsif (ref($dir) eq 'GLOB') { + # A file handle + } + elsif (ref($dir)) { + Carp::croak("Illegal argument to parse_dir()"); + } + elsif ($dir =~ /^\*\w+(::\w+)+$/) { + # This scalar looks like a file handle, so we assume it is + } + else { + # A normal scalar listing + $dir = [ split(/\n/, $dir) ]; + } + + $pkg->init(); + + my @files = (); + if (ref($dir) eq 'ARRAY') { + for (@$dir) { + push(@files, $pkg->line($_, $tz, $error)); + } + } + else { + local($_); + while (<$dir>) { + chomp; + push(@files, $pkg->line($_, $tz, $error)); + } + } + wantarray ? @files : \@files; +} + + + +package File::Listing::unix; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir @ISA); + +@ISA = qw(File::Listing); + + + +sub init +{ + $curdir = ''; +} + + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + #study; + + my ($kind, $size, $date, $name); + if (($kind, $size, $date, $name) = + /^([\-FlrwxsStTdD]{10}) # Type and permission bits + .* # Graps + \D(\d+) # File size + \s+ # Some space + (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}) # Date + \s+ # Some more space + (.*)$ # File name + /x ) + + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) { + $name = $1; + $type = "l $2"; + } + elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file + $type = 'f'; + } + elsif ($kind =~ /^[dD]/) { + $type = 'd'; + $size = undef; # Don't believe the reported size + } + return [$name, $type, $size, str2time($date, $tz), + File::Listing::file_mode($kind)]; + + } + elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) { + my $dir = $1; + return () if $dir eq '.'; + $curdir = $dir; + return (); + } + elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) { + return (); + } + elsif (/not found/ || # OSF1, HPUX, and SunOS return + # "$file not found" + /No such file/ || # IRIX returns + # "UX:ls: ERROR: Cannot access $file: No such file or directory" + # Solaris returns + # "$file: No such file or directory" + /cannot find/ # Windows NT returns + # "The system cannot find the path specified." + ) { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Error: $_\n" if $error eq 'warn'; + return (); + } + elsif ($_ eq '') { # AIX, and Linux return nothing + return () unless defined $error; + &$error("No such file or directory") if ref($error) eq 'CODE'; + warn "Warning: No such file or directory\n" if $error eq 'warn'; + return (); + } + else { + # parse failed, check if the dosftp parse understands it + File::Listing::dosftp->init(); + return(File::Listing::dosftp->line($_,$tz,$error)); + } + +} + + + +package File::Listing::dosftp; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir @ISA); + +@ISA = qw(File::Listing); + + + +sub init +{ + $curdir = ''; +} + + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + + my ($date, $size_or_dir, $name, $size); + + # 02-05-96 10:48AM 1415 src.slf + # 09-10-96 09:18AM <DIR> sl_util + if (($date, $size_or_dir, $name) = + /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info + \s+ # Some space + (<\w{3}>|\d+) # Dir or Size + \s+ # Some more space + (.+)$ # File name + /x ) + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($size_or_dir eq '<DIR>') { + $type = "d"; + $size = ""; # directories have no size in the pc listing + } + else { + $type = 'f'; + $size = $size_or_dir; + } + return [$name, $type, $size, str2time($date, $tz), undef]; + } + else { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Can't parse: $_\n" if $error eq 'warn'; + return (); + } + +} + + + +package File::Listing::vms; +@File::Listing::vms::ISA = qw(File::Listing); + +package File::Listing::netware; +@File::Listing::netware::ISA = qw(File::Listing); + + + +package File::Listing::apache; + +use vars qw(@ISA); + +@ISA = qw(File::Listing); + + +sub init { } + + +sub line { + shift; # package name + local($_) = shift; + my($tz, $error) = @_; # ignored for now... + + if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) { + my($filename, $filesize) = ($1, $7); + my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6); + if ($m =~ /^\d+$/) { + ($d,$y) = ($y,$d) # iso date + } + else { + $m = _monthabbrev_number($m); + } + + $filesize = 0 if $filesize eq '-'; + if ($filesize =~ s/k$//i) { + $filesize *= 1024; + } + elsif ($filesize =~ s/M$//) { + $filesize *= 1024*1024; + } + elsif ($filesize =~ s/G$//) { + $filesize *= 1024*1024*1024; + } + $filesize = int $filesize; + + require Time::Local; + my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900); + my $filetype = ($filename =~ s|/$|| ? "d" : "f"); + return [$filename, $filetype, $filesize, $filetime, undef]; + } + + return (); +} + + +sub _guess_year { + my $y = shift; + if ($y >= 90) { + $y = 1900+$y; + } + elsif ($y < 100) { + $y = 2000+$y; + } + $y; +} + + +sub _monthabbrev_number { + my $mon = shift; + +{'Jan' => 1, + 'Feb' => 2, + 'Mar' => 3, + 'Apr' => 4, + 'May' => 5, + 'Jun' => 6, + 'Jul' => 7, + 'Aug' => 8, + 'Sep' => 9, + 'Oct' => 10, + 'Nov' => 11, + 'Dec' => 12, + }->{$mon}; +} + + +1; + +__END__ + +=head1 NAME + +File::Listing - parse directory listing + +=head1 SYNOPSIS + + use File::Listing qw(parse_dir); + $ENV{LANG} = "C"; # dates in non-English locales not supported + for (parse_dir(`ls -l`)) { + ($name, $type, $size, $mtime, $mode) = @$_; + next if $type ne 'f'; # plain file + #... + } + + # directory listing can also be read from a file + open(LISTING, "zcat ls-lR.gz|"); + $dir = parse_dir(\*LISTING, '+0000'); + +=head1 DESCRIPTION + +This module exports a single function called parse_dir(), which can be +used to parse directory listings. + +The first parameter to parse_dir() is the directory listing to parse. +It can be a scalar, a reference to an array of directory lines or a +glob representing a filehandle to read the directory listing from. + +The second parameter is the time zone to use when parsing time stamps +in the listing. If this value is undefined, then the local time zone is +assumed. + +The third parameter is the type of listing to assume. Currently +supported formats are 'unix', 'apache' and 'dosftp'. The default +value 'unix'. Ideally, the listing type should be determined +automatically. + +The fourth parameter specifies how unparseable lines should be treated. +Values can be 'ignore', 'warn' or a code reference. Warn means that +the perl warn() function will be called. If a code reference is +passed, then this routine will be called and the return value from it +will be incorporated in the listing. The default is 'ignore'. + +Only the first parameter is mandatory. + +The return value from parse_dir() is a list of directory entries. In +a scalar context the return value is a reference to the list. The +directory entries are represented by an array consisting of [ +$filename, $filetype, $filesize, $filetime, $filemode ]. The +$filetype value is one of the letters 'f', 'd', 'l' or '?'. The +$filetime value is the seconds since Jan 1, 1970. The +$filemode is a bitmask like the mode returned by stat(). + +=head1 CREDITS + +Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and +Net::FTP's parse_dir (Graham Barr). diff --git a/Master/tlpkg/tlperl/lib/HTML/Entities.pm b/Master/tlpkg/tlperl/lib/HTML/Entities.pm new file mode 100644 index 00000000000..9cba0c896ad --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/Entities.pm @@ -0,0 +1,485 @@ +package HTML::Entities; + +=encoding utf8 + +=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.68"; +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 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 100644 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 100644 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 100644 index 00000000000..af3da842aed --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTML/HeadParser.pm @@ -0,0 +1,307 @@ +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.66"; + +=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') { + my $decoded; + $decoded = utf8::decode($text) if $self->utf8_mode && defined &utf8::decode; + HTML::Entities::decode($text); + utf8::encode($text) if $decoded; + $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;)> +# +# From HTML 5 as of WD-html5-20090825: +# +# One or more elements of metadata content, [...] +# => base, command, link, meta, noscript, script, style, title + +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 100644 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 100644 index 00000000000..67f42e29c0e --- /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.68"; + +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/html4/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 + +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) + +L<http://www.w3.org/TR/html4/> + +More information about marked sections and processing instructions may +be found at L<http://www.is-thought.co.uk/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 100644 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 100644 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 100644 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 diff --git a/Master/tlpkg/tlperl/lib/HTTP/Config.pm b/Master/tlpkg/tlperl/lib/HTTP/Config.pm new file mode 100644 index 00000000000..c7d9df53711 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Config.pm @@ -0,0 +1,436 @@ +package HTTP::Config; + +use strict; +use URI; +use vars qw($VERSION); + +$VERSION = "5.835"; + +sub new { + my $class = shift; + return bless [], $class; +} + +sub entries { + my $self = shift; + @$self; +} + +sub empty { + my $self = shift; + not @$self; +} + +sub add { + if (@_ == 2) { + my $self = shift; + push(@$self, shift); + return; + } + my($self, %spec) = @_; + push(@$self, \%spec); + return; +} + +sub find2 { + my($self, %spec) = @_; + my @found; + my @rest; + ITEM: + for my $item (@$self) { + for my $k (keys %spec) { + if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) { + push(@rest, $item); + next ITEM; + } + } + push(@found, $item); + } + return \@found unless wantarray; + return \@found, \@rest; +} + +sub find { + my $self = shift; + my $f = $self->find2(@_); + return @$f if wantarray; + return $f->[0]; +} + +sub remove { + my($self, %spec) = @_; + my($removed, $rest) = $self->find2(%spec); + @$self = @$rest if @$removed; + return @$removed; +} + +my %MATCH = ( + m_scheme => sub { + my($v, $uri) = @_; + return $uri->_scheme eq $v; # URI known to be canonical + }, + m_secure => sub { + my($v, $uri) = @_; + my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https"; + return $secure == !!$v; + }, + m_host_port => sub { + my($v, $uri) = @_; + return unless $uri->can("host_port"); + return $uri->host_port eq $v, 7; + }, + m_host => sub { + my($v, $uri) = @_; + return unless $uri->can("host"); + return $uri->host eq $v, 6; + }, + m_port => sub { + my($v, $uri) = @_; + return unless $uri->can("port"); + return $uri->port eq $v; + }, + m_domain => sub { + my($v, $uri) = @_; + return unless $uri->can("host"); + my $h = $uri->host; + $h = "$h.local" unless $h =~ /\./; + $v = ".$v" unless $v =~ /^\./; + return length($v), 5 if substr($h, -length($v)) eq $v; + return 0; + }, + m_path => sub { + my($v, $uri) = @_; + return unless $uri->can("path"); + return $uri->path eq $v, 4; + }, + m_path_prefix => sub { + my($v, $uri) = @_; + return unless $uri->can("path"); + my $path = $uri->path; + my $len = length($v); + return $len, 3 if $path eq $v; + return 0 if length($path) <= $len; + $v .= "/" unless $v =~ m,/\z,,; + return $len, 3 if substr($path, 0, length($v)) eq $v; + return 0; + }, + m_path_match => sub { + my($v, $uri) = @_; + return unless $uri->can("path"); + return $uri->path =~ $v; + }, + m_uri__ => sub { + my($v, $k, $uri) = @_; + return unless $uri->can($k); + return 1 unless defined $v; + return $uri->$k eq $v; + }, + m_method => sub { + my($v, $uri, $request) = @_; + return $request && $request->method eq $v; + }, + m_proxy => sub { + my($v, $uri, $request) = @_; + return $request && ($request->{proxy} || "") eq $v; + }, + m_code => sub { + my($v, $uri, $request, $response) = @_; + $v =~ s/xx\z//; + return unless $response; + return length($v), 2 if substr($response->code, 0, length($v)) eq $v; + }, + m_media_type => sub { # for request too?? + my($v, $uri, $request, $response) = @_; + return unless $response; + return 1, 1 if $v eq "*/*"; + my $ct = $response->content_type; + return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,; + return 3, 1 if $v eq "html" && $response->content_is_html; + return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml; + return 10, 1 if $v eq $ct; + return 0; + }, + m_header__ => sub { + my($v, $k, $uri, $request, $response) = @_; + return unless $request; + return 1 if $request->header($k) eq $v; + return 1 if $response && $response->header($k) eq $v; + return 0; + }, + m_response_attr__ => sub { + my($v, $k, $uri, $request, $response) = @_; + return unless $response; + return 1 if !defined($v) && exists $response->{$k}; + return 0 unless exists $response->{$k}; + return 1 if $response->{$k} eq $v; + return 0; + }, +); + +sub matching { + my $self = shift; + if (@_ == 1) { + if ($_[0]->can("request")) { + unshift(@_, $_[0]->request); + unshift(@_, undef) unless defined $_[0]; + } + unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical"); + } + my($uri, $request, $response) = @_; + $uri = URI->new($uri) unless ref($uri); + + my @m; + ITEM: + for my $item (@$self) { + my $order; + for my $ikey (keys %$item) { + my $mkey = $ikey; + my $k; + $k = $1 if $mkey =~ s/__(.*)/__/; + if (my $m = $MATCH{$mkey}) { + #print "$ikey $mkey\n"; + my($c, $o); + my @arg = ( + defined($k) ? $k : (), + $uri, $request, $response + ); + my $v = $item->{$ikey}; + $v = [$v] unless ref($v) eq "ARRAY"; + for (@$v) { + ($c, $o) = $m->($_, @arg); + #print " - $_ ==> $c $o\n"; + last if $c; + } + next ITEM unless $c; + $order->[$o || 0] += $c; + } + } + $order->[7] ||= 0; + $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order); + push(@m, $item); + } + @m = sort { $b->{_order} cmp $a->{_order} } @m; + delete $_->{_order} for @m; + return @m if wantarray; + return $m[0]; +} + +sub add_item { + my $self = shift; + my $item = shift; + return $self->add(item => $item, @_); +} + +sub remove_items { + my $self = shift; + return map $_->{item}, $self->remove(@_); +} + +sub matching_items { + my $self = shift; + return map $_->{item}, $self->matching(@_); +} + +1; + +__END__ + +=head1 NAME + +HTTP::Config - Configuration for request and response objects + +=head1 SYNOPSIS + + use HTTP::Config; + my $c = HTTP::Config->new; + $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1); + + use HTTP::Request; + my $request = HTTP::Request->new(GET => "http://www.example.com"); + + if (my @m = $c->matching($request)) { + print "Yadayada\n" if $m[0]->{verbose}; + } + +=head1 DESCRIPTION + +An C<HTTP::Config> object is a list of entries that +can be matched against request or request/response pairs. Its +purpose is to hold configuration data that can be looked up given a +request or response object. + +Each configuration entry is a hash. Some keys specify matching to +occur against attributes of request/response objects. Other keys can +be used to hold user data. + +The following methods are provided: + +=over 4 + +=item $conf = HTTP::Config->new + +Constructs a new empty C<HTTP::Config> object and returns it. + +=item $conf->entries + +Returns the list of entries in the configuration object. +In scalar context returns the number of entries. + +=item $conf->empty + +Return true if there are no entries in the configuration object. +This is just a shorthand for C<< not $conf->entries >>. + +=item $conf->add( %matchspec, %other ) + +=item $conf->add( \%entry ) + +Adds a new entry to the configuration. +You can either pass separate key/value pairs or a hash reference. + +=item $conf->remove( %spec ) + +Removes (and returns) the entries that have matches for all the key/value pairs in %spec. +If %spec is empty this will match all entries; so it will empty the configuation object. + +=item $conf->matching( $uri, $request, $response ) + +=item $conf->matching( $uri ) + +=item $conf->matching( $request ) + +=item $conf->matching( $response ) + +Returns the entries that match the given $uri, $request and $response triplet. + +If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method. +If called with a single $response object, then the request object is obtained by calling its 'request' method; +and then the $uri is obtained as if a single $request was provided. + +The entries are returned with the most specific matches first. +In scalar context returns the most specific match or C<undef> in none match. + +=item $conf->add_item( $item, %matchspec ) + +=item $conf->remove_items( %spec ) + +=item $conf->matching_items( $uri, $request, $response ) + +Wrappers that hides the entries themselves. + +=back + +=head2 Matching + +The following keys on a configuration entry specify matching. For all +of these you can provide an array of values instead of a single value. +The entry matches if at least one of the values in the array matches. + +Entries that require match against a response object attribute will never match +unless a response object was provided. + +=over + +=item m_scheme => $scheme + +Matches if the URI uses the specified scheme; e.g. "http". + +=item m_secure => $bool + +If $bool is TRUE; matches if the URI uses a secure scheme. If $bool +is FALSE; matches if the URI does not use a secure scheme. An example +of a secure scheme is "https". + +=item m_host_port => "$hostname:$port" + +Matches if the URI's host_port method return the specified value. + +=item m_host => $hostname + +Matches if the URI's host method returns the specified value. + +=item m_port => $port + +Matches if the URI's port method returns the specified value. + +=item m_domain => ".$domain" + +Matches if the URI's host method return a value that within the given +domain. The hostname "www.example.com" will for instance match the +domain ".com". + +=item m_path => $path + +Matches if the URI's path method returns the specified value. + +=item m_path_prefix => $path + +Matches if the URI's path is the specified path or has the specified +path as prefix. + +=item m_path_match => $Regexp + +Matches if the regular expression matches the URI's path. Eg. qr/\.html$/. + +=item m_method => $method + +Matches if the request method matches the specified value. Eg. "GET" or "POST". + +=item m_code => $digit + +=item m_code => $status_code + +Matches if the response status code matches. If a single digit is +specified; matches for all response status codes beginning with that digit. + +=item m_proxy => $url + +Matches if the request is to be sent to the given Proxy server. + +=item m_media_type => "*/*" + +=item m_media_type => "text/*" + +=item m_media_type => "html" + +=item m_media_type => "xhtml" + +=item m_media_type => "text/html" + +Matches if the response media type matches. + +With a value of "html" matches if $response->content_is_html returns TRUE. +With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE. + +=item m_uri__I<$method> => undef + +Matches if the URI object provides the method. + +=item m_uri__I<$method> => $string + +Matches if the URI's $method method returns the given value. + +=item m_header__I<$field> => $string + +Matches if either the request or the response have a header $field with the given value. + +=item m_response_attr__I<$key> => undef + +=item m_response_attr__I<$key> => $string + +Matches if the response object has that key, or the entry has the given value. + +=back + +=head1 SEE ALSO + +L<URI>, L<HTTP::Request>, L<HTTP::Response> + +=head1 COPYRIGHT + +Copyright 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/HTTP/Cookies.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm new file mode 100644 index 00000000000..831a4ace15c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm @@ -0,0 +1,781 @@ +package HTTP::Cookies; + +use strict; +use HTTP::Date qw(str2time parse_date time2str); +use HTTP::Headers::Util qw(_split_header_words join_header_words); + +use vars qw($VERSION $EPOCH_OFFSET); +$VERSION = "5.837"; + +# Legacy: because "use "HTTP::Cookies" used be the ONLY way +# to load the class HTTP::Cookies::Netscape. +require HTTP::Cookies::Netscape; + +$EPOCH_OFFSET = 0; # difference from Unix epoch +if ($^O eq "MacOS") { + require Time::Local; + $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70); +} + +# A HTTP::Cookies object is a hash. The main attribute is the +# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}. + +sub new +{ + my $class = shift; + my $self = bless { + COOKIES => {}, + }, $class; + my %cnf = @_; + for (keys %cnf) { + $self->{lc($_)} = $cnf{$_}; + } + $self->load; + $self; +} + + +sub add_cookie_header +{ + my $self = shift; + my $request = shift || return; + my $url = $request->uri; + my $scheme = $url->scheme; + unless ($scheme =~ /^https?\z/) { + return; + } + + my $domain = _host($request, $url); + $domain = "$domain.local" unless $domain =~ /\./; + my $secure_request = ($scheme eq "https"); + my $req_path = _url_path($url); + my $req_port = $url->port; + my $now = time(); + _normalize_path($req_path) if $req_path =~ /%/; + + my @cval; # cookie values for the "Cookie" header + my $set_ver; + my $netscape_only = 0; # An exact domain match applies to any cookie + + while ($domain =~ /\./) { + # Checking $domain for cookies" + my $cookies = $self->{COOKIES}{$domain}; + next unless $cookies; + if ($self->{delayload} && defined($cookies->{'//+delayload'})) { + my $cookie_data = $cookies->{'//+delayload'}{'cookie'}; + delete $self->{COOKIES}{$domain}; + $self->load_cookie($cookie_data->[1]); + $cookies = $self->{COOKIES}{$domain}; + next unless $cookies; # should not really happen + } + + # Want to add cookies corresponding to the most specific paths + # first (i.e. longest path first) + my $path; + for $path (sort {length($b) <=> length($a) } keys %$cookies) { + if (index($req_path, $path) != 0) { + next; + } + + my($key,$array); + while (($key,$array) = each %{$cookies->{$path}}) { + my($version,$val,$port,$path_spec,$secure,$expires) = @$array; + if ($secure && !$secure_request) { + next; + } + if ($expires && $expires < $now) { + next; + } + if ($port) { + my $found; + if ($port =~ s/^_//) { + # The corresponding Set-Cookie attribute was empty + $found++ if $port eq $req_port; + $port = ""; + } + else { + my $p; + for $p (split(/,/, $port)) { + $found++, last if $p eq $req_port; + } + } + unless ($found) { + next; + } + } + if ($version > 0 && $netscape_only) { + next; + } + + # set version number of cookie header. + # XXX: What should it be if multiple matching + # Set-Cookie headers have different versions themselves + if (!$set_ver++) { + if ($version >= 1) { + push(@cval, "\$Version=$version"); + } + elsif (!$self->{hide_cookie2}) { + $request->header(Cookie2 => '$Version="1"'); + } + } + + # do we need to quote the value + if ($val =~ /\W/ && $version) { + $val =~ s/([\\\"])/\\$1/g; + $val = qq("$val"); + } + + # and finally remember this cookie + push(@cval, "$key=$val"); + if ($version >= 1) { + push(@cval, qq(\$Path="$path")) if $path_spec; + push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./; + if (defined $port) { + my $p = '$Port'; + $p .= qq(="$port") if length $port; + push(@cval, $p); + } + } + + } + } + + } continue { + # Try with a more general domain, alternately stripping + # leading name components and leading dots. When this + # results in a domain with no leading dot, it is for + # Netscape cookie compatibility only: + # + # a.b.c.net Any cookie + # .b.c.net Any cookie + # b.c.net Netscape cookie only + # .c.net Any cookie + + if ($domain =~ s/^\.+//) { + $netscape_only = 1; + } + else { + $domain =~ s/[^.]*//; + $netscape_only = 0; + } + } + + if (@cval) { + if (my $old = $request->header("Cookie")) { + unshift(@cval, $old); + } + $request->header(Cookie => join("; ", @cval)); + } + + $request; +} + + +sub extract_cookies +{ + my $self = shift; + my $response = shift || return; + + my @set = _split_header_words($response->_header("Set-Cookie2")); + my @ns_set = $response->_header("Set-Cookie"); + + return $response unless @set || @ns_set; # quick exit + + my $request = $response->request; + my $url = $request->uri; + my $req_host = _host($request, $url); + $req_host = "$req_host.local" unless $req_host =~ /\./; + my $req_port = $url->port; + my $req_path = _url_path($url); + _normalize_path($req_path) if $req_path =~ /%/; + + if (@ns_set) { + # The old Netscape cookie format for Set-Cookie + # http://curl.haxx.se/rfc/cookie_spec.html + # can for instance contain an unquoted "," in the expires + # field, so we have to use this ad-hoc parser. + my $now = time(); + + # Build a hash of cookies that was present in Set-Cookie2 + # headers. We need to skip them if we also find them in a + # Set-Cookie header. + my %in_set2; + for (@set) { + $in_set2{$_->[0]}++; + } + + my $set; + for $set (@ns_set) { + $set =~ s/^\s+//; + my @cur; + my $param; + my $expires; + my $first_param = 1; + for $param (split(/;\s*/, $set)) { + next unless length($param); + my($k,$v) = split(/\s*=\s*/, $param, 2); + if (defined $v) { + $v =~ s/\s+$//; + #print "$k => $v\n"; + } + else { + $k =~ s/\s+$//; + #print "$k => undef"; + } + if (!$first_param && lc($k) eq "expires") { + my $etime = str2time($v); + if (defined $etime) { + push(@cur, "Max-Age" => $etime - $now); + $expires++; + } + else { + # parse_date can deal with years outside the range of time_t, + my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v); + if ($year) { + my $thisyear = (gmtime)[5] + 1900; + if ($year < $thisyear) { + push(@cur, "Max-Age" => -1); # any negative value will do + $expires++; + } + elsif ($year >= $thisyear + 10) { + # the date is at least 10 years into the future, just replace + # it with something approximate + push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60); + $expires++; + } + } + } + } + elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) { + # ignore + } + else { + push(@cur, $k => $v); + } + $first_param = 0; + } + next unless @cur; + next if $in_set2{$cur[0]}; + +# push(@cur, "Port" => $req_port); + push(@cur, "Discard" => undef) unless $expires; + push(@cur, "Version" => 0); + push(@cur, "ns-cookie" => 1); + push(@set, \@cur); + } + } + + SET_COOKIE: + for my $set (@set) { + next unless @$set >= 2; + + my $key = shift @$set; + my $val = shift @$set; + + my %hash; + while (@$set) { + my $k = shift @$set; + my $v = shift @$set; + my $lc = lc($k); + # don't loose case distinction for unknown fields + $k = $lc if $lc =~ /^(?:discard|domain|max-age| + path|port|secure|version)$/x; + if ($k eq "discard" || $k eq "secure") { + $v = 1 unless defined $v; + } + next if exists $hash{$k}; # only first value is significant + $hash{$k} = $v; + }; + + my %orig_hash = %hash; + my $version = delete $hash{version}; + $version = 1 unless defined($version); + my $discard = delete $hash{discard}; + my $secure = delete $hash{secure}; + my $maxage = delete $hash{'max-age'}; + my $ns_cookie = delete $hash{'ns-cookie'}; + + # Check domain + my $domain = delete $hash{domain}; + $domain = lc($domain) if defined $domain; + if (defined($domain) + && $domain ne $req_host && $domain ne ".$req_host") { + if ($domain !~ /\./ && $domain ne "local") { + next SET_COOKIE; + } + $domain = ".$domain" unless $domain =~ /^\./; + if ($domain =~ /\.\d+$/) { + next SET_COOKIE; + } + my $len = length($domain); + unless (substr($req_host, -$len) eq $domain) { + next SET_COOKIE; + } + my $hostpre = substr($req_host, 0, length($req_host) - $len); + if ($hostpre =~ /\./ && !$ns_cookie) { + next SET_COOKIE; + } + } + else { + $domain = $req_host; + } + + my $path = delete $hash{path}; + my $path_spec; + if (defined $path && $path ne '') { + $path_spec++; + _normalize_path($path) if $path =~ /%/; + if (!$ns_cookie && + substr($req_path, 0, length($path)) ne $path) { + next SET_COOKIE; + } + } + else { + $path = $req_path; + $path =~ s,/[^/]*$,,; + $path = "/" unless length($path); + } + + my $port; + if (exists $hash{port}) { + $port = delete $hash{port}; + if (defined $port) { + $port =~ s/\s+//g; + my $found; + for my $p (split(/,/, $port)) { + unless ($p =~ /^\d+$/) { + next SET_COOKIE; + } + $found++ if $p eq $req_port; + } + unless ($found) { + next SET_COOKIE; + } + } + else { + $port = "_$req_port"; + } + } + $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash) + if $self->set_cookie_ok(\%orig_hash); + } + + $response; +} + +sub set_cookie_ok +{ + 1; +} + + +sub set_cookie +{ + my $self = shift; + my($version, + $key, $val, $path, $domain, $port, + $path_spec, $secure, $maxage, $discard, $rest) = @_; + + # path and key can not be empty (key can't start with '$') + return $self if !defined($path) || $path !~ m,^/, || + !defined($key) || $key =~ m,^\$,; + + # ensure legal port + if (defined $port) { + return $self unless $port =~ /^_?\d+(?:,\d+)*$/; + } + + my $expires; + if (defined $maxage) { + if ($maxage <= 0) { + delete $self->{COOKIES}{$domain}{$path}{$key}; + return $self; + } + $expires = time() + $maxage; + } + $version = 0 unless defined $version; + + my @array = ($version, $val,$port, + $path_spec, + $secure, $expires, $discard); + push(@array, {%$rest}) if defined($rest) && %$rest; + # trim off undefined values at end + pop(@array) while !defined $array[-1]; + + $self->{COOKIES}{$domain}{$path}{$key} = \@array; + $self; +} + + +sub save +{ + my $self = shift; + my $file = shift || $self->{'file'} || return; + local(*FILE); + open(FILE, ">$file") or die "Can't open $file: $!"; + print FILE "#LWP-Cookies-1.0\n"; + print FILE $self->as_string(!$self->{ignore_discard}); + close(FILE); + 1; +} + + +sub load +{ + my $self = shift; + my $file = shift || $self->{'file'} || return; + local(*FILE, $_); + local $/ = "\n"; # make sure we got standard record separator + open(FILE, $file) or return; + my $magic = <FILE>; + unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) { + warn "$file does not seem to contain cookies"; + return; + } + while (<FILE>) { + next unless s/^Set-Cookie3:\s*//; + chomp; + my $cookie; + for $cookie (_split_header_words($_)) { + my($key,$val) = splice(@$cookie, 0, 2); + my %hash; + while (@$cookie) { + my $k = shift @$cookie; + my $v = shift @$cookie; + $hash{$k} = $v; + } + my $version = delete $hash{version}; + my $path = delete $hash{path}; + my $domain = delete $hash{domain}; + my $port = delete $hash{port}; + my $expires = str2time(delete $hash{expires}); + + my $path_spec = exists $hash{path_spec}; delete $hash{path_spec}; + my $secure = exists $hash{secure}; delete $hash{secure}; + my $discard = exists $hash{discard}; delete $hash{discard}; + + my @array = ($version,$val,$port, + $path_spec,$secure,$expires,$discard); + push(@array, \%hash) if %hash; + $self->{COOKIES}{$domain}{$path}{$key} = \@array; + } + } + close(FILE); + 1; +} + + +sub revert +{ + my $self = shift; + $self->clear->load; + $self; +} + + +sub clear +{ + my $self = shift; + if (@_ == 0) { + $self->{COOKIES} = {}; + } + elsif (@_ == 1) { + delete $self->{COOKIES}{$_[0]}; + } + elsif (@_ == 2) { + delete $self->{COOKIES}{$_[0]}{$_[1]}; + } + elsif (@_ == 3) { + delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]}; + } + else { + require Carp; + Carp::carp('Usage: $c->clear([domain [,path [,key]]])'); + } + $self; +} + + +sub clear_temporary_cookies +{ + my($self) = @_; + + $self->scan(sub { + if($_[9] or # "Discard" flag set + not $_[8]) { # No expire field? + $_[8] = -1; # Set the expire/max_age field + $self->set_cookie(@_); # Clear the cookie + } + }); +} + + +sub DESTROY +{ + my $self = shift; + local($., $@, $!, $^E, $?); + $self->save if $self->{'autosave'}; +} + + +sub scan +{ + my($self, $cb) = @_; + my($domain,$path,$key); + for $domain (sort keys %{$self->{COOKIES}}) { + for $path (sort keys %{$self->{COOKIES}{$domain}}) { + for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) { + my($version,$val,$port,$path_spec, + $secure,$expires,$discard,$rest) = + @{$self->{COOKIES}{$domain}{$path}{$key}}; + $rest = {} unless defined($rest); + &$cb($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest); + } + } + } +} + + +sub as_string +{ + my($self, $skip_discard) = @_; + my @res; + $self->scan(sub { + my($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest) = @_; + return if $discard && $skip_discard; + my @h = ($key, $val); + push(@h, "path", $path); + push(@h, "domain" => $domain); + push(@h, "port" => $port) if defined $port; + push(@h, "path_spec" => undef) if $path_spec; + push(@h, "secure" => undef) if $secure; + push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires; + push(@h, "discard" => undef) if $discard; + my $k; + for $k (sort keys %$rest) { + push(@h, $k, $rest->{$k}); + } + push(@h, "version" => $version); + push(@res, "Set-Cookie3: " . join_header_words(\@h)); + }); + join("\n", @res, ""); +} + +sub _host +{ + my($request, $url) = @_; + if (my $h = $request->header("Host")) { + $h =~ s/:\d+$//; # might have a port as well + return lc($h); + } + return lc($url->host); +} + +sub _url_path +{ + my $url = shift; + my $path; + if($url->can('epath')) { + $path = $url->epath; # URI::URL method + } + else { + $path = $url->path; # URI::_generic method + } + $path = "/" unless length $path; + $path; +} + +sub _normalize_path # so that plain string compare can be used +{ + my $x; + $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/ + $x = uc($1); + $x eq "2F" || $x eq "25" ? "%$x" : + pack("C", hex($x)); + /eg; + $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg; +} + +1; + +__END__ + +=head1 NAME + +HTTP::Cookies - HTTP cookie jars + +=head1 SYNOPSIS + + use HTTP::Cookies; + $cookie_jar = HTTP::Cookies->new( + file => "$ENV{'HOME'}/lwp_cookies.dat", + autosave => 1, + ); + + use LWP; + my $browser = LWP::UserAgent->new; + $browser->cookie_jar($cookie_jar); + +Or for an empty and temporary cookie jar: + + use LWP; + my $browser = LWP::UserAgent->new; + $browser->cookie_jar( {} ); + +=head1 DESCRIPTION + +This class is for objects that represent a "cookie jar" -- that is, a +database of all the HTTP cookies that a given LWP::UserAgent object +knows about. + +Cookies are a general mechanism which server side connections can use +to both store and retrieve information on the client side of the +connection. For more information about cookies refer to +<URL:http://curl.haxx.se/rfc/cookie_spec.html> and +<URL:http://www.cookiecentral.com/>. This module also implements the +new style cookies described in I<RFC 2965>. +The two variants of cookies are supposed to be able to coexist happily. + +Instances of the class I<HTTP::Cookies> are able to store a collection +of Set-Cookie2: and Set-Cookie: headers and are able to use this +information to initialize Cookie-headers in I<HTTP::Request> objects. +The state of a I<HTTP::Cookies> object can be saved in and restored from +files. + +=head1 METHODS + +The following methods are provided: + +=over 4 + +=item $cookie_jar = HTTP::Cookies->new + +The constructor takes hash style parameters. The following +parameters are recognized: + + file: name of the file to restore cookies from and save cookies to + autosave: save during destruction (bool) + ignore_discard: save even cookies that are requested to be discarded (bool) + hide_cookie2: do not add Cookie2 header to requests + +Future parameters might include (not yet implemented): + + max_cookies 300 + max_cookies_per_domain 20 + max_cookie_size 4096 + + no_cookies list of domain names that we never return cookies to + +=item $cookie_jar->add_cookie_header( $request ) + +The add_cookie_header() method will set the appropriate Cookie:-header +for the I<HTTP::Request> object given as argument. The $request must +have a valid url attribute before this method is called. + +=item $cookie_jar->extract_cookies( $response ) + +The extract_cookies() method will look for Set-Cookie: and +Set-Cookie2: headers in the I<HTTP::Response> object passed as +argument. Any of these headers that are found are used to update +the state of the $cookie_jar. + +=item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest ) + +The set_cookie() method updates the state of the $cookie_jar. The +$key, $val, $domain, $port and $path arguments are strings. The +$path_spec, $secure, $discard arguments are boolean values. The $maxage +value is a number indicating number of seconds that this cookie will +live. A value <= 0 will delete this cookie. %rest defines +various other attributes like "Comment" and "CommentURL". + +=item $cookie_jar->save + +=item $cookie_jar->save( $file ) + +This method file saves the state of the $cookie_jar to a file. +The state can then be restored later using the load() method. If a +filename is not specified we will use the name specified during +construction. If the attribute I<ignore_discard> is set, then we +will even save cookies that are marked to be discarded. + +The default is to save a sequence of "Set-Cookie3" lines. +"Set-Cookie3" is a proprietary LWP format, not known to be compatible +with any browser. The I<HTTP::Cookies::Netscape> sub-class can +be used to save in a format compatible with Netscape. + +=item $cookie_jar->load + +=item $cookie_jar->load( $file ) + +This method reads the cookies from the file and adds them to the +$cookie_jar. The file must be in the format written by the save() +method. + +=item $cookie_jar->revert + +This method empties the $cookie_jar and re-loads the $cookie_jar +from the last save file. + +=item $cookie_jar->clear + +=item $cookie_jar->clear( $domain ) + +=item $cookie_jar->clear( $domain, $path ) + +=item $cookie_jar->clear( $domain, $path, $key ) + +Invoking this method without arguments will empty the whole +$cookie_jar. If given a single argument only cookies belonging to +that domain will be removed. If given two arguments, cookies +belonging to the specified path within that domain are removed. If +given three arguments, then the cookie with the specified key, path +and domain is removed. + +=item $cookie_jar->clear_temporary_cookies + +Discard all temporary cookies. Scans for all cookies in the jar +with either no expire field or a true C<discard> flag. To be +called when the user agent shuts down according to RFC 2965. + +=item $cookie_jar->scan( \&callback ) + +The argument is a subroutine that will be invoked for each cookie +stored in the $cookie_jar. The subroutine will be invoked with +the following arguments: + + 0 version + 1 key + 2 val + 3 path + 4 domain + 5 port + 6 path_spec + 7 secure + 8 expires + 9 discard + 10 hash + +=item $cookie_jar->as_string + +=item $cookie_jar->as_string( $skip_discardables ) + +The as_string() method will return the state of the $cookie_jar +represented as a sequence of "Set-Cookie3" header lines separated by +"\n". If $skip_discardables is TRUE, it will not return lines for +cookies with the I<Discard> attribute. + +=back + +=head1 SEE ALSO + +L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft> + +=head1 COPYRIGHT + +Copyright 1997-2002 Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm new file mode 100644 index 00000000000..c5a0bf77087 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm @@ -0,0 +1,329 @@ +package HTTP::Cookies::Microsoft; + +use strict; + +use vars qw(@ISA $VERSION); + +$VERSION = "5.821"; + +require HTTP::Cookies; +@ISA=qw(HTTP::Cookies); + +sub load_cookies_from_file +{ + my ($file) = @_; + my @cookies; + my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire); + my ($lo_create, $hi_create, $sep); + + open(COOKIES, $file) || return; + + while ($key = <COOKIES>) + { + chomp($key); + chomp($value = <COOKIES>); + chomp($domain_path= <COOKIES>); + chomp($flags = <COOKIES>); # 0x0001 bit is for secure + chomp($lo_expire = <COOKIES>); + chomp($hi_expire = <COOKIES>); + chomp($lo_create = <COOKIES>); + chomp($hi_create = <COOKIES>); + chomp($sep = <COOKIES>); + + if (!defined($key) || !defined($value) || !defined($domain_path) || + !defined($flags) || !defined($hi_expire) || !defined($lo_expire) || + !defined($hi_create) || !defined($lo_create) || !defined($sep) || + ($sep ne '*')) + { + last; + } + + if ($domain_path =~ /^([^\/]+)(\/.*)$/) + { + my $domain = $1; + my $path = $2; + + push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain, + PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire, + LOXP => $lo_expire, HICREATE => $hi_create, + LOCREATE => $lo_create}); + } + } + + return \@cookies; +} + +sub get_user_name +{ + use Win32; + use locale; + my $user = lc(Win32::LoginName()); + + return $user; +} + +# MSIE stores create and expire times as Win32 FILETIME, +# which is 64 bits of 100 nanosecond intervals since Jan 01 1601 +# +# But Cookies code expects time in 32-bit value expressed +# in seconds since Jan 01 1970 +# +sub epoch_time_offset_from_win32_filetime +{ + my ($high, $low) = @_; + + #-------------------------------------------------------- + # USEFUL CONSTANT + #-------------------------------------------------------- + # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME + # + # 100 nanosecond intervals == 0.1 microsecond intervals + + my $filetime_low32_1970 = 0xd53e8000; + my $filetime_high32_1970 = 0x019db1de; + + #------------------------------------ + # ALGORITHM + #------------------------------------ + # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970: + # + # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base + # 2. Divide by 10 to get to microseconds (1/millionth second) + # 3. Divide by 1000000 (10 ^ 6) to get to seconds + # + # We can combine Step 2 & 3 into one divide. + # + # After much trial and error, I came up with the following code which + # avoids using Math::BigInt or floating pt, but still gives correct answers + + # If the filetime is before the epoch, return 0 + if (($high < $filetime_high32_1970) || + (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970))) + { + return 0; + } + + # Can't multiply by 0x100000000, (1 << 32), + # without Perl issuing an integer overflow warning + # + # So use two multiplies by 0x10000 instead of one multiply by 0x100000000 + # + # The result is the same. + # + my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970; + my $time = (($high * 0x10000) * 0x10000) + $low; + + $time -= $date1970; + $time /= 10000000; + + return $time; +} + +sub load_cookie +{ + my($self, $file) = @_; + my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; + my $cookie_data; + + if (-f $file) + { + # open the cookie file and get the data + $cookie_data = load_cookies_from_file($file); + + foreach my $cookie (@{$cookie_data}) + { + my $secure = ($cookie->{FLAGS} & 1) != 0; + my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP}); + + $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE}, + $cookie->{PATH}, $cookie->{DOMAIN}, undef, + 0, $secure, $expires-$now, 0); + } + } +} + +sub load +{ + my($self, $cookie_index) = @_; + my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; + my $cookie_dir = ''; + my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'}); + my $user_name = get_user_name(); + my $data; + + $cookie_index ||= $self->{'file'} || return; + if ($cookie_index =~ /[\\\/][^\\\/]+$/) + { + $cookie_dir = $` . "\\"; + } + + local(*INDEX, $_); + + open(INDEX, $cookie_index) || return; + binmode(INDEX); + if (256 != read(INDEX, $data, 256)) + { + warn "$cookie_index file is not large enough"; + close(INDEX); + return; + } + + # Cookies' index.dat file starts with 32 bytes of signature + # followed by an offset to the first record, stored as a little-endian DWORD + my ($sig, $size) = unpack('a32 V', $data); + + if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0) + (0x4000 != $size)) + { + warn "$cookie_index ['$sig' $size] does not seem to contain cookies"; + close(INDEX); + return; + } + + if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record + { + close(INDEX); + return; + } + + # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes) + # so read in two 0x80 byte sectors and adjust if not a Cookie. + while (256 == read(INDEX, $data, 256)) + { + # each record starts with a 4-byte signature + # and a count (little-endian DWORD) of 0x80 byte sectors for the record + ($sig, $size) = unpack('a4 V', $data); + + # Cookies are found in 'URL ' records + if ('URL ' ne $sig) + { + # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records + if (($sig eq 'HASH') || ($sig eq 'LEAK')) + { + # '-2' takes into account the two 0x80 byte sectors we've just read in + if (($size > 0) && ($size != 2)) + { + if (0 == seek(INDEX, ($size-2)*0x80, 1)) + { + # Seek failed. Something's wrong. Gonna stop. + last; + } + } + } + next; + } + + #$REMOVE Need to check if URL records in Cookies' index.dat will + # ever use more than two 0x80 byte sectors + if ($size > 2) + { + my $more_data = ($size-2)*0x80; + + if ($more_data != read(INDEX, $data, $more_data, 256)) + { + last; + } + } + + (my $user_name2 = $user_name) =~ s/ /_/g; + if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/) + { + my $cookie_file = $cookie_dir . $2; # form full pathname + + if (!$delay_load) + { + $self->load_cookie($cookie_file); + } + else + { + my $domain = $1; + + # grab only the domain name, drop everything from the first dir sep on + if ($domain =~ m{[\\/]}) + { + $domain = $`; + } + + # set the delayload cookie for this domain with + # the cookie_file as cookie for later-loading info + $self->set_cookie(undef, 'cookie', $cookie_file, + '//+delayload', $domain, undef, + 0, 0, $now+86400, 0); + } + } + } + + close(INDEX); + + 1; +} + +1; + +__END__ + +=head1 NAME + +HTTP::Cookies::Microsoft - access to Microsoft cookies files + +=head1 SYNOPSIS + + use LWP; + use HTTP::Cookies::Microsoft; + use Win32::TieRegistry(Delimiter => "/"); + my $cookies_dir = $Registry-> + {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"}; + + $cookie_jar = HTTP::Cookies::Microsoft->new( + file => "$cookies_dir\\index.dat", + 'delayload' => 1, + ); + my $browser = LWP::UserAgent->new; + $browser->cookie_jar( $cookie_jar ); + +=head1 DESCRIPTION + +This is a subclass of C<HTTP::Cookies> which +loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE) +cookie files. + +See the documentation for L<HTTP::Cookies>. + +=head1 METHODS + +The following methods are provided: + +=over 4 + +=item $cookie_jar = HTTP::Cookies::Microsoft->new; + +The constructor takes hash style parameters. In addition +to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft +recognizes the following: + + delayload: delay loading of cookie data until a request + is actually made. This results in faster + runtime unless you use most of the cookies + since only the domain's cookie data + is loaded on demand. + +=back + +=head1 CAVEATS + +Please note that the code DOESN'T support saving to the MSIE +cookie file format. + +=head1 AUTHOR + +Johnny Lee <typo_pl@hotmail.com> + +=head1 COPYRIGHT + +Copyright 2002 Johnny Lee + +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/HTTP/Cookies/Netscape.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm new file mode 100644 index 00000000000..f19c517f946 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm @@ -0,0 +1,114 @@ +package HTTP::Cookies::Netscape; + +use strict; +use vars qw(@ISA $VERSION); + +$VERSION = "5.832"; + +require HTTP::Cookies; +@ISA=qw(HTTP::Cookies); + +sub load +{ + my($self, $file) = @_; + $file ||= $self->{'file'} || return; + local(*FILE, $_); + local $/ = "\n"; # make sure we got standard record separator + my @cookies; + open(FILE, $file) || return; + my $magic = <FILE>; + unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) { + warn "$file does not look like a netscape cookies file" if $^W; + close(FILE); + return; + } + my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; + while (<FILE>) { + next if /^\s*\#/; + next if /^\s*$/; + tr/\n\r//d; + my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_); + $secure = ($secure eq "TRUE"); + $self->set_cookie(undef,$key,$val,$path,$domain,undef, + 0,$secure,$expires-$now, 0); + } + close(FILE); + 1; +} + +sub save +{ + my($self, $file) = @_; + $file ||= $self->{'file'} || return; + local(*FILE, $_); + open(FILE, ">$file") || return; + + # Use old, now broken link to the old cookie spec just in case something + # else (not us!) requires the comment block exactly this way. + print FILE <<EOT; +# Netscape HTTP Cookie File +# http://www.netscape.com/newsref/std/cookie_spec.html +# This is a generated file! Do not edit. + +EOT + + my $now = time - $HTTP::Cookies::EPOCH_OFFSET; + $self->scan(sub { + my($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest) = @_; + return if $discard && !$self->{ignore_discard}; + $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0; + return if $now > $expires; + $secure = $secure ? "TRUE" : "FALSE"; + my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE"; + print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n"; + }); + close(FILE); + 1; +} + +1; +__END__ + +=head1 NAME + +HTTP::Cookies::Netscape - access to Netscape cookies files + +=head1 SYNOPSIS + + use LWP; + use HTTP::Cookies::Netscape; + $cookie_jar = HTTP::Cookies::Netscape->new( + file => "c:/program files/netscape/users/ZombieCharity/cookies.txt", + ); + my $browser = LWP::UserAgent->new; + $browser->cookie_jar( $cookie_jar ); + +=head1 DESCRIPTION + +This is a subclass of C<HTTP::Cookies> that reads (and optionally +writes) Netscape/Mozilla cookie files. + +See the documentation for L<HTTP::Cookies>. + +=head1 CAVEATS + +Please note that the Netscape/Mozilla cookie file format can't store +all the information available in the Set-Cookie2 headers, so you will +probably lose some information if you save in this format. + +At time of writing, this module seems to work fine with Mozilla +Phoenix/Firebird. + +=head1 SEE ALSO + +L<HTTP::Cookies::Microsoft> + +=head1 COPYRIGHT + +Copyright 2002-2003 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/HTTP/Daemon.pm b/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm new file mode 100644 index 00000000000..cf61147d077 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm @@ -0,0 +1,903 @@ +package HTTP::Daemon; + +use strict; +use vars qw($VERSION @ISA $PROTO $DEBUG); + +$VERSION = "5.827"; + +use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa); +@ISA=qw(IO::Socket::INET); + +$PROTO = "HTTP/1.1"; + + +sub new +{ + my($class, %args) = @_; + $args{Listen} ||= 5; + $args{Proto} ||= 'tcp'; + return $class->SUPER::new(%args); +} + + +sub accept +{ + my $self = shift; + my $pkg = shift || "HTTP::Daemon::ClientConn"; + my ($sock, $peer) = $self->SUPER::accept($pkg); + if ($sock) { + ${*$sock}{'httpd_daemon'} = $self; + return wantarray ? ($sock, $peer) : $sock; + } + else { + return; + } +} + + +sub url +{ + my $self = shift; + my $url = $self->_default_scheme . "://"; + my $addr = $self->sockaddr; + if (!$addr || $addr eq INADDR_ANY) { + require Sys::Hostname; + $url .= lc Sys::Hostname::hostname(); + } + else { + $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr); + } + my $port = $self->sockport; + $url .= ":$port" if $port != $self->_default_port; + $url .= "/"; + $url; +} + + +sub _default_port { + 80; +} + + +sub _default_scheme { + "http"; +} + + +sub product_tokens +{ + "libwww-perl-daemon/$HTTP::Daemon::VERSION"; +} + + + +package HTTP::Daemon::ClientConn; + +use vars qw(@ISA $DEBUG); +use IO::Socket (); +@ISA=qw(IO::Socket::INET); +*DEBUG = \$HTTP::Daemon::DEBUG; + +use HTTP::Request (); +use HTTP::Response (); +use HTTP::Status; +use HTTP::Date qw(time2str); +use LWP::MediaTypes qw(guess_media_type); +use Carp (); + +my $CRLF = "\015\012"; # "\r\n" is not portable +my $HTTP_1_0 = _http_version("HTTP/1.0"); +my $HTTP_1_1 = _http_version("HTTP/1.1"); + + +sub get_request +{ + my($self, $only_headers) = @_; + if (${*$self}{'httpd_nomore'}) { + $self->reason("No more requests from this connection"); + return; + } + + $self->reason(""); + my $buf = ${*$self}{'httpd_rbuf'}; + $buf = "" unless defined $buf; + + my $timeout = $ {*$self}{'io_socket_timeout'}; + my $fdset = ""; + vec($fdset, $self->fileno, 1) = 1; + local($_); + + READ_HEADER: + while (1) { + # loop until we have the whole header in $buf + $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines + if ($buf =~ /\012/) { # potential, has at least one line + if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) { + if ($buf =~ /\015?\012\015?\012/) { + last READ_HEADER; # we have it + } + elsif (length($buf) > 16*1024) { + $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE + $self->reason("Very long header"); + return; + } + } + else { + last READ_HEADER; # HTTP/0.9 client + } + } + elsif (length($buf) > 16*1024) { + $self->send_error(414); # REQUEST_URI_TOO_LARGE + $self->reason("Very long first line"); + return; + } + print STDERR "Need more data for complete header\n" if $DEBUG; + return unless $self->_need_more($buf, $timeout, $fdset); + } + if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { + ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0"); + $self->send_error(400); # BAD_REQUEST + $self->reason("Bad request line: $buf"); + return; + } + my $method = $1; + my $uri = $2; + my $proto = $3 || "HTTP/0.9"; + $uri = "http://$uri" if $method eq "CONNECT"; + $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url); + my $r = HTTP::Request->new($method, $uri); + $r->protocol($proto); + ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto); + ${*$self}{'httpd_head'} = ($method eq "HEAD"); + + if ($proto >= $HTTP_1_0) { + # we expect to find some headers + my($key, $val); + HEADER: + while ($buf =~ s/^([^\012]*)\012//) { + $_ = $1; + s/\015$//; + if (/^([^:\s]+)\s*:\s*(.*)/) { + $r->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } + elsif (/^\s+(.*)/) { + $val .= " $1"; + } + else { + last HEADER; + } + } + $r->push_header($key, $val) if $key; + } + + my $conn = $r->header('Connection'); + if ($proto >= $HTTP_1_1) { + ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/; + } + else { + ${*$self}{'httpd_nomore'}++ unless $conn && + lc($conn) =~ /\bkeep-alive\b/; + } + + if ($only_headers) { + ${*$self}{'httpd_rbuf'} = $buf; + return $r; + } + + # Find out how much content to read + my $te = $r->header('Transfer-Encoding'); + my $ct = $r->header('Content-Type'); + my $len = $r->header('Content-Length'); + + # Act on the Expect header, if it's there + for my $e ( $r->header('Expect') ) { + if( lc($e) eq '100-continue' ) { + $self->send_status_line(100); + $self->send_crlf; + } + else { + $self->send_error(417); + $self->reason("Unsupported Expect header value"); + return; + } + } + + if ($te && lc($te) eq 'chunked') { + # Handle chunked transfer encoding + my $body = ""; + CHUNK: + while (1) { + print STDERR "Chunked\n" if $DEBUG; + if ($buf =~ s/^([^\012]*)\012//) { + my $chunk_head = $1; + unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) { + $self->send_error(400); + $self->reason("Bad chunk header $chunk_head"); + return; + } + my $size = hex($1); + last CHUNK if $size == 0; + + my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end + # must read until we have a complete chunk + while ($missing > 0) { + print STDERR "Need $missing more bytes\n" if $DEBUG; + my $n = $self->_need_more($buf, $timeout, $fdset); + return unless $n; + $missing -= $n; + } + $body .= substr($buf, 0, $size); + substr($buf, 0, $size+2) = ''; + + } + else { + # need more data in order to have a complete chunk header + return unless $self->_need_more($buf, $timeout, $fdset); + } + } + $r->content($body); + + # pretend it was a normal entity body + $r->remove_header('Transfer-Encoding'); + $r->header('Content-Length', length($body)); + + my($key, $val); + FOOTER: + while (1) { + if ($buf !~ /\012/) { + # need at least one line to look at + return unless $self->_need_more($buf, $timeout, $fdset); + } + else { + $buf =~ s/^([^\012]*)\012//; + $_ = $1; + s/\015$//; + if (/^([\w\-]+)\s*:\s*(.*)/) { + $r->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } + elsif (/^\s+(.*)/) { + $val .= " $1"; + } + elsif (!length) { + last FOOTER; + } + else { + $self->reason("Bad footer syntax"); + return; + } + } + } + $r->push_header($key, $val) if $key; + + } + elsif ($te) { + $self->send_error(501); # Unknown transfer encoding + $self->reason("Unknown transfer encoding '$te'"); + return; + + } + elsif ($len) { + # Plain body specified by "Content-Length" + my $missing = $len - length($buf); + while ($missing > 0) { + print "Need $missing more bytes of content\n" if $DEBUG; + my $n = $self->_need_more($buf, $timeout, $fdset); + return unless $n; + $missing -= $n; + } + if (length($buf) > $len) { + $r->content(substr($buf,0,$len)); + substr($buf, 0, $len) = ''; + } + else { + $r->content($buf); + $buf=''; + } + } + elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) { + # Handle multipart content type + my $boundary = "$CRLF--$2--"; + my $index; + while (1) { + $index = index($buf, $boundary); + last if $index >= 0; + # end marker not yet found + return unless $self->_need_more($buf, $timeout, $fdset); + } + $index += length($boundary); + $r->content(substr($buf, 0, $index)); + substr($buf, 0, $index) = ''; + + } + ${*$self}{'httpd_rbuf'} = $buf; + + $r; +} + + +sub _need_more +{ + my $self = shift; + #my($buf,$timeout,$fdset) = @_; + if ($_[1]) { + my($timeout, $fdset) = @_[1,2]; + print STDERR "select(,,,$timeout)\n" if $DEBUG; + my $n = select($fdset,undef,undef,$timeout); + unless ($n) { + $self->reason(defined($n) ? "Timeout" : "select: $!"); + return; + } + } + print STDERR "sysread()\n" if $DEBUG; + my $n = sysread($self, $_[0], 2048, length($_[0])); + $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n; + $n; +} + + +sub read_buffer +{ + my $self = shift; + my $old = ${*$self}{'httpd_rbuf'}; + if (@_) { + ${*$self}{'httpd_rbuf'} = shift; + } + $old; +} + + +sub reason +{ + my $self = shift; + my $old = ${*$self}{'httpd_reason'}; + if (@_) { + ${*$self}{'httpd_reason'} = shift; + } + $old; +} + + +sub proto_ge +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} >= _http_version(shift); +} + + +sub _http_version +{ + local($_) = shift; + return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i; + $1 * 1000 + $2; +} + + +sub antique_client +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} < $HTTP_1_0; +} + + +sub force_last_request +{ + my $self = shift; + ${*$self}{'httpd_nomore'}++; +} + +sub head_request +{ + my $self = shift; + ${*$self}{'httpd_head'}; +} + + +sub send_status_line +{ + my($self, $status, $message, $proto) = @_; + return if $self->antique_client; + $status ||= RC_OK; + $message ||= status_message($status) || ""; + $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1"; + print $self "$proto $status $message$CRLF"; +} + + +sub send_crlf +{ + my $self = shift; + print $self $CRLF; +} + + +sub send_basic_header +{ + my $self = shift; + return if $self->antique_client; + $self->send_status_line(@_); + print $self "Date: ", time2str(time), $CRLF; + my $product = $self->daemon->product_tokens; + print $self "Server: $product$CRLF" if $product; +} + + +sub send_header +{ + my $self = shift; + while (@_) { + my($k, $v) = splice(@_, 0, 2); + $v = "" unless defined($v); + print $self "$k: $v$CRLF"; + } +} + + +sub send_response +{ + my $self = shift; + my $res = shift; + if (!ref $res) { + $res ||= RC_OK; + $res = HTTP::Response->new($res, @_); + } + my $content = $res->content; + my $chunked; + unless ($self->antique_client) { + my $code = $res->code; + $self->send_basic_header($code, $res->message, $res->protocol); + if ($code =~ /^(1\d\d|[23]04)$/) { + # make sure content is empty + $res->remove_header("Content-Length"); + $content = ""; + } + elsif ($res->request && $res->request->method eq "HEAD") { + # probably OK + } + elsif (ref($content) eq "CODE") { + if ($self->proto_ge("HTTP/1.1")) { + $res->push_header("Transfer-Encoding" => "chunked"); + $chunked++; + } + else { + $self->force_last_request; + } + } + elsif (length($content)) { + $res->header("Content-Length" => length($content)); + } + else { + $self->force_last_request; + $res->header('connection','close'); + } + print $self $res->headers_as_string($CRLF); + print $self $CRLF; # separates headers and content + } + if ($self->head_request) { + # no content + } + elsif (ref($content) eq "CODE") { + while (1) { + my $chunk = &$content(); + last unless defined($chunk) && length($chunk); + if ($chunked) { + printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF; + } + else { + print $self $chunk; + } + } + print $self "0$CRLF$CRLF" if $chunked; # no trailers either + } + elsif (length $content) { + print $self $content; + } +} + + +sub send_redirect +{ + my($self, $loc, $status, $content) = @_; + $status ||= RC_MOVED_PERMANENTLY; + Carp::croak("Status '$status' is not redirect") unless is_redirect($status); + $self->send_basic_header($status); + my $base = $self->daemon->url; + $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc); + $loc = $loc->abs($base); + print $self "Location: $loc$CRLF"; + if ($content) { + my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain"; + print $self "Content-Type: $ct$CRLF"; + } + print $self $CRLF; + print $self $content if $content && !$self->head_request; + $self->force_last_request; # no use keeping the connection open +} + + +sub send_error +{ + my($self, $status, $error) = @_; + $status ||= RC_BAD_REQUEST; + Carp::croak("Status '$status' is not an error") unless is_error($status); + my $mess = status_message($status); + $error ||= ""; + $mess = <<EOT; +<title>$status $mess</title> +<h1>$status $mess</h1> +$error +EOT + unless ($self->antique_client) { + $self->send_basic_header($status); + print $self "Content-Type: text/html$CRLF"; + print $self "Content-Length: " . length($mess) . $CRLF; + print $self $CRLF; + } + print $self $mess unless $self->head_request; + $status; +} + + +sub send_file_response +{ + my($self, $file) = @_; + if (-d $file) { + $self->send_dir($file); + } + elsif (-f _) { + # plain file + local(*F); + sysopen(F, $file, 0) or + return $self->send_error(RC_FORBIDDEN); + binmode(F); + my($ct,$ce) = guess_media_type($file); + my($size,$mtime) = (stat _)[7,9]; + unless ($self->antique_client) { + $self->send_basic_header; + print $self "Content-Type: $ct$CRLF"; + print $self "Content-Encoding: $ce$CRLF" if $ce; + print $self "Content-Length: $size$CRLF" if $size; + print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime; + print $self $CRLF; + } + $self->send_file(\*F) unless $self->head_request; + return RC_OK; + } + else { + $self->send_error(RC_NOT_FOUND); + } +} + + +sub send_dir +{ + my($self, $dir) = @_; + $self->send_error(RC_NOT_FOUND) unless -d $dir; + $self->send_error(RC_NOT_IMPLEMENTED); +} + + +sub send_file +{ + my($self, $file) = @_; + my $opened = 0; + local(*FILE); + if (!ref($file)) { + open(FILE, $file) || return undef; + binmode(FILE); + $file = \*FILE; + $opened++; + } + my $cnt = 0; + my $buf = ""; + my $n; + while ($n = sysread($file, $buf, 8*1024)) { + last if !$n; + $cnt += $n; + print $self $buf; + } + close($file) if $opened; + $cnt; +} + + +sub daemon +{ + my $self = shift; + ${*$self}{'httpd_daemon'}; +} + + +1; + +__END__ + +=head1 NAME + +HTTP::Daemon - a simple http server class + +=head1 SYNOPSIS + + use HTTP::Daemon; + use HTTP::Status; + + my $d = HTTP::Daemon->new || die; + print "Please contact me at: <URL:", $d->url, ">\n"; + while (my $c = $d->accept) { + while (my $r = $c->get_request) { + if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") { + # remember, this is *not* recommended practice :-) + $c->send_file_response("/etc/passwd"); + } + else { + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + } + +=head1 DESCRIPTION + +Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that +listen on a socket for incoming requests. The C<HTTP::Daemon> is a +subclass of C<IO::Socket::INET>, so you can perform socket operations +directly on it too. + +The accept() method will return when a connection from a client is +available. The returned value will be an C<HTTP::Daemon::ClientConn> +object which is another C<IO::Socket::INET> subclass. Calling the +get_request() method on this object will read data from the client and +return an C<HTTP::Request> object. The ClientConn object also provide +methods to send back various responses. + +This HTTP daemon does not fork(2) for you. Your application, i.e. the +user of the C<HTTP::Daemon> is responsible for forking if that is +desirable. Also note that the user is responsible for generating +responses that conform to the HTTP/1.1 protocol. + +The following methods of C<HTTP::Daemon> are new (or enhanced) relative +to the C<IO::Socket::INET> base class: + +=over 4 + +=item $d = HTTP::Daemon->new + +=item $d = HTTP::Daemon->new( %opts ) + +The constructor method takes the same arguments as the +C<IO::Socket::INET> constructor, but unlike its base class it can also +be called without any arguments. The daemon will then set up a listen +queue of 5 connections and allocate some random port number. + +A server that wants to bind to some specific address on the standard +HTTP port will be constructed like this: + + $d = HTTP::Daemon->new( + LocalAddr => 'www.thisplace.com', + LocalPort => 80, + ); + +See L<IO::Socket::INET> for a description of other arguments that can +be used configure the daemon during construction. + +=item $c = $d->accept + +=item $c = $d->accept( $pkg ) + +=item ($c, $peer_addr) = $d->accept + +This method works the same the one provided by the base class, but it +returns an C<HTTP::Daemon::ClientConn> reference by default. If a +package name is provided as argument, then the returned object will be +blessed into the given class. It is probably a good idea to make that +class a subclass of C<HTTP::Daemon::ClientConn>. + +The accept method will return C<undef> if timeouts have been enabled +and no connection is made within the given time. The timeout() method +is described in L<IO::Socket>. + +In list context both the client object and the peer address will be +returned; see the description of the accept method L<IO::Socket> for +details. + +=item $d->url + +Returns a URL string that can be used to access the server root. + +=item $d->product_tokens + +Returns the name that this server will use to identify itself. This +is the string that is sent with the C<Server> response header. The +main reason to have this method is that subclasses can override it if +they want to use another product name. + +The default is the string "libwww-perl-daemon/#.##" where "#.##" is +replaced with the version number of this module. + +=back + +The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET> +subclass. Instances of this class are returned by the accept() method +of C<HTTP::Daemon>. The following methods are provided: + +=over 4 + +=item $c->get_request + +=item $c->get_request( $headers_only ) + +This method reads data from the client and turns it into an +C<HTTP::Request> object which is returned. It returns C<undef> +if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn> +object ($c) should be discarded, and you should not try call this +method again on it. The $c->reason method might give you some +information about why $c->get_request failed. + +The get_request() method will normally not return until the whole +request has been received from the client. This might not be what you +want if the request is an upload of a large file (and with chunked +transfer encoding HTTP can even support infinite request messages - +uploading live audio for instance). If you pass a TRUE value as the +$headers_only argument, then get_request() will return immediately +after parsing the request headers and you are responsible for reading +the rest of the request content. If you are going to call +$c->get_request again on the same connection you better read the +correct number of bytes. + +=item $c->read_buffer + +=item $c->read_buffer( $new_value ) + +Bytes read by $c->get_request, but not used are placed in the I<read +buffer>. The next time $c->get_request is called it will consume the +bytes in this buffer before reading more data from the network +connection itself. The read buffer is invalid after $c->get_request +has failed. + +If you handle the reading of the request content yourself you need to +empty this buffer before you read more and you need to place +unconsumed bytes here. You also need this buffer if you implement +services like I<101 Switching Protocols>. + +This method always returns the old buffer content and can optionally +replace the buffer content if you pass it an argument. + +=item $c->reason + +When $c->get_request returns C<undef> you can obtain a short string +describing why it happened by calling $c->reason. + +=item $c->proto_ge( $proto ) + +Return TRUE if the client announced a protocol with version number +greater or equal to the given argument. The $proto argument can be a +string like "HTTP/1.1" or just "1.1". + +=item $c->antique_client + +Return TRUE if the client speaks the HTTP/0.9 protocol. No status +code and no headers should be returned to such a client. This should +be the same as !$c->proto_ge("HTTP/1.0"). + +=item $c->head_request + +Return TRUE if the last request was a C<HEAD> request. No content +body must be generated for these requests. + +=item $c->force_last_request + +Make sure that $c->get_request will not try to read more requests off +this connection. If you generate a response that is not self +delimiting, then you should signal this fact by calling this method. + +This attribute is turned on automatically if the client announces +protocol HTTP/1.0 or worse and does not include a "Connection: +Keep-Alive" header. It is also turned on automatically when HTTP/1.1 +or better clients send the "Connection: close" request header. + +=item $c->send_status_line + +=item $c->send_status_line( $code ) + +=item $c->send_status_line( $code, $mess ) + +=item $c->send_status_line( $code, $mess, $proto ) + +Send the status line back to the client. If $code is omitted 200 is +assumed. If $mess is omitted, then a message corresponding to $code +is inserted. If $proto is missing the content of the +$HTTP::Daemon::PROTO variable is used. + +=item $c->send_crlf + +Send the CRLF sequence to the client. + +=item $c->send_basic_header + +=item $c->send_basic_header( $code ) + +=item $c->send_basic_header( $code, $mess ) + +=item $c->send_basic_header( $code, $mess, $proto ) + +Send the status line and the "Date:" and "Server:" headers back to +the client. This header is assumed to be continued and does not end +with an empty CRLF line. + +See the description of send_status_line() for the description of the +accepted arguments. + +=item $c->send_header( $field, $value ) + +=item $c->send_header( $field1, $value1, $field2, $value2, ... ) + +Send one or more header lines. + +=item $c->send_response( $res ) + +Write a C<HTTP::Response> object to the +client as a response. We try hard to make sure that the response is +self delimiting so that the connection can stay persistent for further +request/response exchanges. + +The content attribute of the C<HTTP::Response> object can be a normal +string or a subroutine reference. If it is a subroutine, then +whatever this callback routine returns is written back to the +client as the response content. The routine will be called until it +return an undefined or empty value. If the client is HTTP/1.1 aware +then we will use chunked transfer encoding for the response. + +=item $c->send_redirect( $loc ) + +=item $c->send_redirect( $loc, $code ) + +=item $c->send_redirect( $loc, $code, $entity_body ) + +Send a redirect response back to the client. The location ($loc) can +be an absolute or relative URL. The $code must be one the redirect +status codes, and defaults to "301 Moved Permanently" + +=item $c->send_error + +=item $c->send_error( $code ) + +=item $c->send_error( $code, $error_message ) + +Send an error response back to the client. If the $code is missing a +"Bad Request" error is reported. The $error_message is a string that +is incorporated in the body of the HTML entity body. + +=item $c->send_file_response( $filename ) + +Send back a response with the specified $filename as content. If the +file is a directory we try to generate an HTML index of it. + +=item $c->send_file( $filename ) + +=item $c->send_file( $fd ) + +Copy the file to the client. The file can be a string (which +will be interpreted as a filename) or a reference to an C<IO::Handle> +or glob. + +=item $c->daemon + +Return a reference to the corresponding C<HTTP::Daemon> object. + +=back + +=head1 SEE ALSO + +RFC 2616 + +L<IO::Socket::INET>, L<IO::Socket> + +=head1 COPYRIGHT + +Copyright 1996-2003, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/HTTP/Date.pm b/Master/tlpkg/tlperl/lib/HTTP/Date.pm new file mode 100644 index 00000000000..7756214af98 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Date.pm @@ -0,0 +1,389 @@ +package HTTP::Date; + +$VERSION = "5.831"; + +require 5.004; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(time2str str2time); +@EXPORT_OK = qw(parse_date time2iso time2isoz); + +use strict; +require Time::Local; + +use vars qw(@DoW @MoY %MoY); +@DoW = qw(Sun Mon Tue Wed Thu Fri Sat); +@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); +@MoY{@MoY} = (1..12); + +my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1); + + +sub time2str (;$) +{ + my $time = shift; + $time = time unless defined $time; + my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time); + sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", + $DoW[$wday], + $mday, $MoY[$mon], $year+1900, + $hour, $min, $sec); +} + + +sub str2time ($;$) +{ + my $str = shift; + return undef unless defined $str; + + # fast exit for strictly conforming string + if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) { + return eval { + my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3); + $t < 0 ? undef : $t; + }; + } + + my @d = parse_date($str); + return undef unless @d; + $d[1]--; # month + + my $tz = pop(@d); + unless (defined $tz) { + unless (defined($tz = shift)) { + return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac)); + my $t = Time::Local::timelocal(reverse @d) + $frac; + $t < 0 ? undef : $t; + }; + } + } + + my $offset = 0; + if ($GMT_ZONE{uc $tz}) { + # offset already zero + } + elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) { + $offset = 3600 * $2; + $offset += 60 * $3 if $3; + $offset *= -1 if $1 && $1 eq '-'; + } + else { + eval { require Time::Zone } || return undef; + $offset = Time::Zone::tz_offset($tz); + return undef unless defined $offset; + } + + return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac)); + my $t = Time::Local::timegm(reverse @d) + $frac; + $t < 0 ? undef : $t - $offset; + }; +} + + +sub parse_date ($) +{ + local($_) = shift; + return unless defined; + + # More lax parsing below + s/^\s+//; # kill leading space + s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday + + my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm); + + # Then we are able to check for most of the formats with this regexp + (($day,$mon,$yr,$hr,$min,$sec,$tz) = + /^ + (\d\d?) # day + (?:\s+|[-\/]) + (\w+) # month + (?:\s+|[-\/]) + (\d+) # year + (?: + (?:\s+|:) # separator before clock + (\d\d?):(\d\d) # hour:min + (?::(\d\d))? # optional seconds + )? # optional clock + \s* + ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone + \s* + (?:\(\w+\))? # ASCII representation of timezone in parens. + \s*$ + /x) + + || + + # Try the ctime and asctime format + (($mon, $day, $hr, $min, $sec, $tz, $yr) = + /^ + (\w{1,3}) # month + \s+ + (\d\d?) # day + \s+ + (\d\d?):(\d\d) # hour:min + (?::(\d\d))? # optional seconds + \s+ + (?:([A-Za-z]+)\s+)? # optional timezone + (\d+) # year + \s*$ # allow trailing whitespace + /x) + + || + + # Then the Unix 'ls -l' date format + (($mon, $day, $yr, $hr, $min, $sec) = + /^ + (\w{3}) # month + \s+ + (\d\d?) # day + \s+ + (?: + (\d\d\d\d) | # year + (\d{1,2}):(\d{2}) # hour:min + (?::(\d\d))? # optional seconds + ) + \s*$ + /x) + + || + + # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants + (($yr, $mon, $day, $hr, $min, $sec, $tz) = + /^ + (\d{4}) # year + [-\/]? + (\d\d?) # numerical month + [-\/]? + (\d\d?) # day + (?: + (?:\s+|[-:Tt]) # separator before clock + (\d\d?):?(\d\d) # hour:min + (?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional) + )? # optional clock + \s* + ([-+]?\d\d?:?(:?\d\d)? + |Z|z)? # timezone (Z is "zero meridian", i.e. GMT) + \s*$ + /x) + + || + + # Windows 'dir' 11-12-96 03:52PM + (($mon, $day, $yr, $hr, $min, $ampm) = + /^ + (\d{2}) # numerical month + - + (\d{2}) # day + - + (\d{2}) # year + \s+ + (\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM + \s*$ + /x) + + || + return; # unrecognized format + + # Translate month name to number + $mon = $MoY{$mon} || + $MoY{"\u\L$mon"} || + ($mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon)) || + return; + + # If the year is missing, we assume first date before the current, + # because of the formats we support such dates are mostly present + # on "ls -l" listings. + unless (defined $yr) { + my $cur_mon; + ($cur_mon, $yr) = (localtime)[4, 5]; + $yr += 1900; + $cur_mon++; + $yr-- if $mon > $cur_mon; + } + elsif (length($yr) < 3) { + # Find "obvious" year + my $cur_yr = (localtime)[5] + 1900; + my $m = $cur_yr % 100; + my $tmp = $yr; + $yr += $cur_yr - $m; + $m -= $tmp; + $yr += ($m > 0) ? 100 : -100 + if abs($m) > 50; + } + + # Make sure clock elements are defined + $hr = 0 unless defined($hr); + $min = 0 unless defined($min); + $sec = 0 unless defined($sec); + + # Compensate for AM/PM + if ($ampm) { + $ampm = uc $ampm; + $hr = 0 if $hr == 12 && $ampm eq 'AM'; + $hr += 12 if $ampm eq 'PM' && $hr != 12; + } + + return($yr, $mon, $day, $hr, $min, $sec, $tz) + if wantarray; + + if (defined $tz) { + $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/; + } + else { + $tz = ""; + } + return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s", + $yr, $mon, $day, $hr, $min, $sec, $tz); +} + + +sub time2iso (;$) +{ + my $time = shift; + $time = time unless defined $time; + my($sec,$min,$hour,$mday,$mon,$year) = localtime($time); + sprintf("%04d-%02d-%02d %02d:%02d:%02d", + $year+1900, $mon+1, $mday, $hour, $min, $sec); +} + + +sub time2isoz (;$) +{ + my $time = shift; + $time = time unless defined $time; + my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time); + sprintf("%04d-%02d-%02d %02d:%02d:%02dZ", + $year+1900, $mon+1, $mday, $hour, $min, $sec); +} + +1; + + +__END__ + +=head1 NAME + +HTTP::Date - date conversion routines + +=head1 SYNOPSIS + + use HTTP::Date; + + $string = time2str($time); # Format as GMT ASCII time + $time = str2time($string); # convert ASCII date to machine time + +=head1 DESCRIPTION + +This module provides functions that deal the date formats used by the +HTTP protocol (and then some more). Only the first two functions, +time2str() and str2time(), are exported by default. + +=over 4 + +=item time2str( [$time] ) + +The time2str() function converts a machine time (seconds since epoch) +to a string. If the function is called without an argument or with an +undefined argument, it will use the current time. + +The string returned is in the format preferred for the HTTP protocol. +This is a fixed length subset of the format defined by RFC 1123, +represented in Universal Time (GMT). An example of a time stamp +in this format is: + + Sun, 06 Nov 1994 08:49:37 GMT + +=item str2time( $str [, $zone] ) + +The str2time() function converts a string to machine time. It returns +C<undef> if the format of $str is unrecognized, otherwise whatever the +C<Time::Local> functions can make out of the parsed time. Dates +before the system's epoch may not work on all operating systems. The +time formats recognized are the same as for parse_date(). + +The function also takes an optional second argument that specifies the +default time zone to use when converting the date. This parameter is +ignored if the zone is found in the date string itself. If this +parameter is missing, and the date string format does not contain any +zone specification, then the local time zone is assumed. + +If the zone is not "C<GMT>" or numerical (like "C<-0800>" or +"C<+0100>"), then the C<Time::Zone> module must be installed in order +to get the date recognized. + +=item parse_date( $str ) + +This function will try to parse a date string, and then return it as a +list of numerical values followed by a (possible undefined) time zone +specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year +returned will B<not> have the number 1900 subtracted from it and the +$month numbers start with 1. + +In scalar context the numbers are interpolated in a string of the +"YYYY-MM-DD hh:mm:ss TZ"-format and returned. + +If the date is unrecognized, then the empty list is returned. + +The function is able to parse the following formats: + + "Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format + "Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format + "Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format + "Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format + "Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format + + "03/Feb/1994:17:03:55 -0700" -- common logfile format + "09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday) + "08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday) + "08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday) + + "1994-02-03 14:15:29 -0100" -- ISO 8601 format + "1994-02-03 14:15:29" -- zone is optional + "1994-02-03" -- only date + "1994-02-03T14:15:29" -- Use T as separator + "19940203T141529Z" -- ISO 8601 compact format + "19940203" -- only date + + "08-Feb-94" -- old rfc850 HTTP format (no weekday, no time) + "08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time) + "09 Feb 1994" -- proposed new HTTP format (no weekday, no time) + "03/Feb/1994" -- common logfile format (no time, no offset) + + "Feb 3 1994" -- Unix 'ls -l' format + "Feb 3 17:03" -- Unix 'ls -l' format + + "11-15-96 03:52PM" -- Windows 'dir' format + +The parser ignores leading and trailing whitespace. It also allow the +seconds to be missing and the month to be numerical in most formats. + +If the year is missing, then we assume that the date is the first +matching date I<before> current month. If the year is given with only +2 digits, then parse_date() will select the century that makes the +year closest to the current date. + +=item time2iso( [$time] ) + +Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted +string representing time in the local time zone. + +=item time2isoz( [$time] ) + +Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted +string representing Universal Time. + + +=back + +=head1 SEE ALSO + +L<perlfunc/time>, L<Time::Zone> + +=head1 COPYRIGHT + +Copyright 1995-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/HTTP/Headers.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers.pm new file mode 100644 index 00000000000..1e9198cd3c7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Headers.pm @@ -0,0 +1,849 @@ +package HTTP::Headers; + +use strict; +use Carp (); + +use vars qw($VERSION $TRANSLATE_UNDERSCORE); +$VERSION = "5.835"; + +# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used +# as a replacement for '-' in header field names. +$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE; + +# "Good Practice" order of HTTP message headers: +# - General-Headers +# - Request-Headers +# - Response-Headers +# - Entity-Headers + +my @general_headers = qw( + Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade + Via Warning +); + +my @request_headers = qw( + Accept Accept-Charset Accept-Encoding Accept-Language + Authorization Expect From Host + If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since + Max-Forwards Proxy-Authorization Range Referer TE User-Agent +); + +my @response_headers = qw( + Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server + Vary WWW-Authenticate +); + +my @entity_headers = qw( + Allow Content-Encoding Content-Language Content-Length Content-Location + Content-MD5 Content-Range Content-Type Expires Last-Modified +); + +my %entity_header = map { lc($_) => 1 } @entity_headers; + +my @header_order = ( + @general_headers, + @request_headers, + @response_headers, + @entity_headers, +); + +# Make alternative representations of @header_order. This is used +# for sorting and case matching. +my %header_order; +my %standard_case; + +{ + my $i = 0; + for (@header_order) { + my $lc = lc $_; + $header_order{$lc} = ++$i; + $standard_case{$lc} = $_; + } +} + + + +sub new +{ + my($class) = shift; + my $self = bless {}, $class; + $self->header(@_) if @_; # set up initial headers + $self; +} + + +sub header +{ + my $self = shift; + Carp::croak('Usage: $h->header($field, ...)') unless @_; + my(@old); + my %seen; + while (@_) { + my $field = shift; + my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET'; + @old = $self->_header($field, shift, $op); + } + return @old if wantarray; + return $old[0] if @old <= 1; + join(", ", @old); +} + +sub clear +{ + my $self = shift; + %$self = (); +} + + +sub push_header +{ + my $self = shift; + return $self->_header(@_, 'PUSH_H') if @_ == 2; + while (@_) { + $self->_header(splice(@_, 0, 2), 'PUSH_H'); + } +} + + +sub init_header +{ + Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3; + shift->_header(@_, 'INIT'); +} + + +sub remove_header +{ + my($self, @fields) = @_; + my $field; + my @values; + foreach $field (@fields) { + $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE; + my $v = delete $self->{lc $field}; + push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v; + } + return @values; +} + +sub remove_content_headers +{ + my $self = shift; + unless (defined(wantarray)) { + # fast branch that does not create return object + delete @$self{grep $entity_header{$_} || /^content-/, keys %$self}; + return; + } + + my $c = ref($self)->new; + for my $f (grep $entity_header{$_} || /^content-/, keys %$self) { + $c->{$f} = delete $self->{$f}; + } + $c; +} + + +sub _header +{ + my($self, $field, $val, $op) = @_; + + unless ($field =~ /^:/) { + $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; + my $old = $field; + $field = lc $field; + unless(defined $standard_case{$field}) { + # generate a %standard_case entry for this field + $old =~ s/\b(\w)/\u$1/g; + $standard_case{$field} = $old; + } + } + + $op ||= defined($val) ? 'SET' : 'GET'; + if ($op eq 'PUSH_H') { + # Like PUSH but where we don't care about the return value + if (exists $self->{$field}) { + my $h = $self->{$field}; + if (ref($h) eq 'ARRAY') { + push(@$h, ref($val) eq "ARRAY" ? @$val : $val); + } + else { + $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val] + } + return; + } + $self->{$field} = $val; + return; + } + + my $h = $self->{$field}; + my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ()); + + unless ($op eq 'GET' || ($op eq 'INIT' && @old)) { + if (defined($val)) { + my @new = ($op eq 'PUSH') ? @old : (); + if (ref($val) ne 'ARRAY') { + push(@new, $val); + } + else { + push(@new, @$val); + } + $self->{$field} = @new > 1 ? \@new : $new[0]; + } + elsif ($op ne 'PUSH') { + delete $self->{$field}; + } + } + @old; +} + + +sub _sorted_field_names +{ + my $self = shift; + return [ sort { + ($header_order{$a} || 999) <=> ($header_order{$b} || 999) || + $a cmp $b + } keys %$self ]; +} + + +sub header_field_names { + my $self = shift; + return map $standard_case{$_} || $_, @{ $self->_sorted_field_names }, + if wantarray; + return keys %$self; +} + + +sub scan +{ + my($self, $sub) = @_; + my $key; + for $key (@{ $self->_sorted_field_names }) { + next if substr($key, 0, 1) eq '_'; + my $vals = $self->{$key}; + if (ref($vals) eq 'ARRAY') { + my $val; + for $val (@$vals) { + $sub->($standard_case{$key} || $key, $val); + } + } + else { + $sub->($standard_case{$key} || $key, $vals); + } + } +} + + +sub as_string +{ + my($self, $endl) = @_; + $endl = "\n" unless defined $endl; + + my @result = (); + for my $key (@{ $self->_sorted_field_names }) { + next if index($key, '_') == 0; + my $vals = $self->{$key}; + if ( ref($vals) eq 'ARRAY' ) { + for my $val (@$vals) { + my $field = $standard_case{$key} || $key; + $field =~ s/^://; + if ( index($val, "\n") >= 0 ) { + $val = _process_newline($val, $endl); + } + push @result, $field . ': ' . $val; + } + } + else { + my $field = $standard_case{$key} || $key; + $field =~ s/^://; + if ( index($vals, "\n") >= 0 ) { + $vals = _process_newline($vals, $endl); + } + push @result, $field . ': ' . $vals; + } + } + + join($endl, @result, ''); +} + +sub _process_newline { + local $_ = shift; + my $endl = shift; + # must handle header values with embedded newlines with care + s/\s+$//; # trailing newlines and space must go + s/\n(\x0d?\n)+/\n/g; # no empty lines + s/\n([^\040\t])/\n $1/g; # intial space for continuation + s/\n/$endl/g; # substitute with requested line ending + $_; +} + + + +if (eval { require Storable; 1 }) { + *clone = \&Storable::dclone; +} else { + *clone = sub { + my $self = shift; + my $clone = HTTP::Headers->new; + $self->scan(sub { $clone->push_header(@_);} ); + $clone; + }; +} + + +sub _date_header +{ + require HTTP::Date; + my($self, $header, $time) = @_; + my($old) = $self->_header($header); + if (defined $time) { + $self->_header($header, HTTP::Date::time2str($time)); + } + $old =~ s/;.*// if defined($old); + HTTP::Date::str2time($old); +} + + +sub date { shift->_date_header('Date', @_); } +sub expires { shift->_date_header('Expires', @_); } +sub if_modified_since { shift->_date_header('If-Modified-Since', @_); } +sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); } +sub last_modified { shift->_date_header('Last-Modified', @_); } + +# This is used as a private LWP extension. The Client-Date header is +# added as a timestamp to a response when it has been received. +sub client_date { shift->_date_header('Client-Date', @_); } + +# The retry_after field is dual format (can also be a expressed as +# number of seconds from now), so we don't provide an easy way to +# access it until we have know how both these interfaces can be +# addressed. One possibility is to return a negative value for +# relative seconds and a positive value for epoch based time values. +#sub retry_after { shift->_date_header('Retry-After', @_); } + +sub content_type { + my $self = shift; + my $ct = $self->{'content-type'}; + $self->{'content-type'} = shift if @_; + $ct = $ct->[0] if ref($ct) eq 'ARRAY'; + return '' unless defined($ct) && length($ct); + my @ct = split(/;\s*/, $ct, 2); + for ($ct[0]) { + s/\s+//g; + $_ = lc($_); + } + wantarray ? @ct : $ct[0]; +} + +sub content_type_charset { + my $self = shift; + require HTTP::Headers::Util; + my $h = $self->{'content-type'}; + $h = $h->[0] if ref($h); + $h = "" unless defined $h; + my @v = HTTP::Headers::Util::split_header_words($h); + if (@v) { + my($ct, undef, %ct_param) = @{$v[0]}; + my $charset = $ct_param{charset}; + if ($ct) { + $ct = lc($ct); + $ct =~ s/\s+//; + } + if ($charset) { + $charset = uc($charset); + $charset =~ s/^\s+//; $charset =~ s/\s+\z//; + undef($charset) if $charset eq ""; + } + return $ct, $charset if wantarray; + return $charset; + } + return undef, undef if wantarray; + return undef; +} + +sub content_is_text { + my $self = shift; + return $self->content_type =~ m,^text/,; +} + +sub content_is_html { + my $self = shift; + return $self->content_type eq 'text/html' || $self->content_is_xhtml; +} + +sub content_is_xhtml { + my $ct = shift->content_type; + return $ct eq "application/xhtml+xml" || + $ct eq "application/vnd.wap.xhtml+xml"; +} + +sub content_is_xml { + my $ct = shift->content_type; + return 1 if $ct eq "text/xml"; + return 1 if $ct eq "application/xml"; + return 1 if $ct =~ /\+xml$/; + return 0; +} + +sub referer { + my $self = shift; + if (@_ && $_[0] =~ /#/) { + # Strip fragment per RFC 2616, section 14.36. + my $uri = shift; + if (ref($uri)) { + $uri = $uri->clone; + $uri->fragment(undef); + } + else { + $uri =~ s/\#.*//; + } + unshift @_, $uri; + } + ($self->_header('Referer', @_))[0]; +} +*referrer = \&referer; # on tchrist's request + +sub title { (shift->_header('Title', @_))[0] } +sub content_encoding { (shift->_header('Content-Encoding', @_))[0] } +sub content_language { (shift->_header('Content-Language', @_))[0] } +sub content_length { (shift->_header('Content-Length', @_))[0] } + +sub user_agent { (shift->_header('User-Agent', @_))[0] } +sub server { (shift->_header('Server', @_))[0] } + +sub from { (shift->_header('From', @_))[0] } +sub warning { (shift->_header('Warning', @_))[0] } + +sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] } +sub authorization { (shift->_header('Authorization', @_))[0] } + +sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] } +sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] } + +sub authorization_basic { shift->_basic_auth("Authorization", @_) } +sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) } + +sub _basic_auth { + require MIME::Base64; + my($self, $h, $user, $passwd) = @_; + my($old) = $self->_header($h); + if (defined $user) { + Carp::croak("Basic authorization user name can't contain ':'") + if $user =~ /:/; + $passwd = '' unless defined $passwd; + $self->_header($h => 'Basic ' . + MIME::Base64::encode("$user:$passwd", '')); + } + if (defined $old && $old =~ s/^\s*Basic\s+//) { + my $val = MIME::Base64::decode($old); + return $val unless wantarray; + return split(/:/, $val, 2); + } + return; +} + + +1; + +__END__ + +=head1 NAME + +HTTP::Headers - Class encapsulating HTTP Message headers + +=head1 SYNOPSIS + + require HTTP::Headers; + $h = HTTP::Headers->new; + + $h->header('Content-Type' => 'text/plain'); # set + $ct = $h->header('Content-Type'); # get + $h->remove_header('Content-Type'); # delete + +=head1 DESCRIPTION + +The C<HTTP::Headers> class encapsulates HTTP-style message headers. +The headers consist of attribute-value pairs also called fields, which +may be repeated, and which are printed in a particular order. The +field names are cases insensitive. + +Instances of this class are usually created as member variables of the +C<HTTP::Request> and C<HTTP::Response> classes, internal to the +library. + +The following methods are available: + +=over 4 + +=item $h = HTTP::Headers->new + +Constructs a new C<HTTP::Headers> object. You might pass some initial +attribute-value pairs as parameters to the constructor. I<E.g.>: + + $h = HTTP::Headers->new( + Date => 'Thu, 03 Feb 1994 00:00:00 GMT', + Content_Type => 'text/html; version=3.2', + Content_Base => 'http://www.perl.org/'); + +The constructor arguments are passed to the C<header> method which is +described below. + +=item $h->clone + +Returns a copy of this C<HTTP::Headers> object. + +=item $h->header( $field ) + +=item $h->header( $field => $value ) + +=item $h->header( $f1 => $v1, $f2 => $v2, ... ) + +Get or set the value of one or more header fields. The header field +name ($field) is not case sensitive. To make the life easier for perl +users who wants to avoid quoting before the => operator, you can use +'_' as a replacement for '-' in header names. + +The header() method accepts multiple ($field => $value) pairs, which +means that you can update several fields with a single invocation. + +The $value argument may be a plain string or a reference to an array +of strings for a multi-valued field. If the $value is provided as +C<undef> then the field is removed. If the $value is not given, then +that header field will remain unchanged. + +The old value (or values) of the last of the header fields is returned. +If no such field exists C<undef> will be returned. + +A multi-valued field will be returned as separate values in list +context and will be concatenated with ", " as separator in scalar +context. The HTTP spec (RFC 2616) promise that joining multiple +values in this way will not change the semantic of a header field, but +in practice there are cases like old-style Netscape cookies (see +L<HTTP::Cookies>) where "," is used as part of the syntax of a single +field value. + +Examples: + + $header->header(MIME_Version => '1.0', + User_Agent => 'My-Web-Client/0.01'); + $header->header(Accept => "text/html, text/plain, image/*"); + $header->header(Accept => [qw(text/html text/plain image/*)]); + @accepts = $header->header('Accept'); # get multiple values + $accepts = $header->header('Accept'); # get values as a single string + +=item $h->push_header( $field => $value ) + +=item $h->push_header( $f1 => $v1, $f2 => $v2, ... ) + +Add a new field value for the specified header field. Previous values +for the same field are retained. + +As for the header() method, the field name ($field) is not case +sensitive and '_' can be used as a replacement for '-'. + +The $value argument may be a scalar or a reference to a list of +scalars. + + $header->push_header(Accept => 'image/jpeg'); + $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]); + +=item $h->init_header( $field => $value ) + +Set the specified header to the given value, but only if no previous +value for that field is set. + +The header field name ($field) is not case sensitive and '_' +can be used as a replacement for '-'. + +The $value argument may be a scalar or a reference to a list of +scalars. + +=item $h->remove_header( $field, ... ) + +This function removes the header fields with the specified names. + +The header field names ($field) are not case sensitive and '_' +can be used as a replacement for '-'. + +The return value is the values of the fields removed. In scalar +context the number of fields removed is returned. + +Note that if you pass in multiple field names then it is generally not +possible to tell which of the returned values belonged to which field. + +=item $h->remove_content_headers + +This will remove all the header fields used to describe the content of +a message. All header field names prefixed with C<Content-> fall +into this category, as well as C<Allow>, C<Expires> and +C<Last-Modified>. RFC 2616 denotes these fields as I<Entity Header +Fields>. + +The return value is a new C<HTTP::Headers> object that contains the +removed headers only. + +=item $h->clear + +This will remove all header fields. + +=item $h->header_field_names + +Returns the list of distinct names for the fields present in the +header. The field names have case as suggested by HTTP spec, and the +names are returned in the recommended "Good Practice" order. + +In scalar context return the number of distinct field names. + +=item $h->scan( \&process_header_field ) + +Apply a subroutine to each header field in turn. The callback routine +is called with two parameters; the name of the field and a single +value (a string). If a header field is multi-valued, then the +routine is called once for each value. The field name passed to the +callback routine has case as suggested by HTTP spec, and the headers +will be visited in the recommended "Good Practice" order. + +Any return values of the callback routine are ignored. The loop can +be broken by raising an exception (C<die>), but the caller of scan() +would have to trap the exception itself. + +=item $h->as_string + +=item $h->as_string( $eol ) + +Return the header fields as a formatted MIME header. Since it +internally uses the C<scan> method to build the string, the result +will use case as suggested by HTTP spec, and it will follow +recommended "Good Practice" of ordering the header fields. Long header +values are not folded. + +The optional $eol parameter specifies the line ending sequence to +use. The default is "\n". Embedded "\n" characters in header field +values will be substituted with this line ending sequence. + +=back + +=head1 CONVENIENCE METHODS + +The most frequently used headers can also be accessed through the +following convenience methods. Most of these methods can both be used to read +and to set the value of a header. The header value is set if you pass +an argument to the method. The old header value is always returned. +If the given header did not exist then C<undef> is returned. + +Methods that deal with dates/times always convert their value to system +time (seconds since Jan 1, 1970) and they also expect this kind of +value when the header value is set. + +=over 4 + +=item $h->date + +This header represents the date and time at which the message was +originated. I<E.g.>: + + $h->date(time); # set current date + +=item $h->expires + +This header gives the date and time after which the entity should be +considered stale. + +=item $h->if_modified_since + +=item $h->if_unmodified_since + +These header fields are used to make a request conditional. If the requested +resource has (or has not) been modified since the time specified in this field, +then the server will return a C<304 Not Modified> response instead of +the document itself. + +=item $h->last_modified + +This header indicates the date and time at which the resource was last +modified. I<E.g.>: + + # check if document is more than 1 hour old + if (my $last_mod = $h->last_modified) { + if ($last_mod < time - 60*60) { + ... + } + } + +=item $h->content_type + +The Content-Type header field indicates the media type of the message +content. I<E.g.>: + + $h->content_type('text/html'); + +The value returned will be converted to lower case, and potential +parameters will be chopped off and returned as a separate value if in +an array context. If there is no such header field, then the empty +string is returned. This makes it safe to do the following: + + if ($h->content_type eq 'text/html') { + # we enter this place even if the real header value happens to + # be 'TEXT/HTML; version=3.0' + ... + } + +=item $h->content_type_charset + +Returns the upper-cased charset specified in the Content-Type header. In list +context return the lower-cased bare content type followed by the upper-cased +charset. Both values will be C<undef> if not specified in the header. + +=item $h->content_is_text + +Returns TRUE if the Content-Type header field indicate that the +content is textual. + +=item $h->content_is_html + +Returns TRUE if the Content-Type header field indicate that the +content is some kind of HTML (including XHTML). This method can't be +used to set Content-Type. + +=item $h->content_is_xhtml + +Returns TRUE if the Content-Type header field indicate that the +content is XHTML. This method can't be used to set Content-Type. + +=item $h->content_is_xml + +Returns TRUE if the Content-Type header field indicate that the +content is XML. This method can't be used to set Content-Type. + +=item $h->content_encoding + +The Content-Encoding header field is used as a modifier to the +media type. When present, its value indicates what additional +encoding mechanism has been applied to the resource. + +=item $h->content_length + +A decimal number indicating the size in bytes of the message content. + +=item $h->content_language + +The natural language(s) of the intended audience for the message +content. The value is one or more language tags as defined by RFC +1766. Eg. "no" for some kind of Norwegian and "en-US" for English the +way it is written in the US. + +=item $h->title + +The title of the document. In libwww-perl this header will be +initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element +of HTML documents. I<This header is no longer part of the HTTP +standard.> + +=item $h->user_agent + +This header field is used in request messages and contains information +about the user agent originating the request. I<E.g.>: + + $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)'); + +=item $h->server + +The server header field contains information about the software being +used by the originating server program handling the request. + +=item $h->from + +This header should contain an Internet e-mail address for the human +user who controls the requesting user agent. The address should be +machine-usable, as defined by RFC822. E.g.: + + $h->from('King Kong <king@kong.com>'); + +I<This header is no longer part of the HTTP standard.> + +=item $h->referer + +Used to specify the address (URI) of the document from which the +requested resource address was obtained. + +The "Free On-line Dictionary of Computing" as this to say about the +word I<referer>: + + <World-Wide Web> A misspelling of "referrer" which + somehow made it into the {HTTP} standard. A given {web + page}'s referer (sic) is the {URL} of whatever web page + contains the link that the user followed to the current + page. Most browsers pass this information as part of a + request. + + (1998-10-19) + +By popular demand C<referrer> exists as an alias for this method so you +can avoid this misspelling in your programs and still send the right +thing on the wire. + +When setting the referrer, this method removes the fragment from the +given URI if it is present, as mandated by RFC2616. Note that +the removal does I<not> happen automatically if using the header(), +push_header() or init_header() methods to set the referrer. + +=item $h->www_authenticate + +This header must be included as part of a C<401 Unauthorized> response. +The field value consist of a challenge that indicates the +authentication scheme and parameters applicable to the requested URI. + +=item $h->proxy_authenticate + +This header must be included in a C<407 Proxy Authentication Required> +response. + +=item $h->authorization + +=item $h->proxy_authorization + +A user agent that wishes to authenticate itself with a server or a +proxy, may do so by including these headers. + +=item $h->authorization_basic + +This method is used to get or set an authorization header that use the +"Basic Authentication Scheme". In array context it will return two +values; the user name and the password. In scalar context it will +return I<"uname:password"> as a single string value. + +When used to set the header value, it expects two arguments. I<E.g.>: + + $h->authorization_basic($uname, $password); + +The method will croak if the $uname contains a colon ':'. + +=item $h->proxy_authorization_basic + +Same as authorization_basic() but will set the "Proxy-Authorization" +header instead. + +=back + +=head1 NON-CANONICALIZED FIELD NAMES + +The header field name spelling is normally canonicalized including the +'_' to '-' translation. There are some application where this is not +appropriate. Prefixing field names with ':' allow you to force a +specific spelling. For example if you really want a header field name +to show up as C<foo_bar> instead of "Foo-Bar", you might set it like +this: + + $h->header(":foo_bar" => 1); + +These field names are returned with the ':' intact for +$h->header_field_names and the $h->scan callback, but the colons do +not show in $h->as_string. + +=head1 COPYRIGHT + +Copyright 1995-2005 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm new file mode 100644 index 00000000000..1e416e2dd9a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm @@ -0,0 +1,98 @@ +package HTTP::Headers::Auth; + +use strict; +use vars qw($VERSION); +$VERSION = "5.817"; + +use HTTP::Headers; + +package HTTP::Headers; + +BEGIN { + # we provide a new (and better) implementations below + undef(&www_authenticate); + undef(&proxy_authenticate); +} + +require HTTP::Headers::Util; + +sub _parse_authenticate +{ + my @ret; + for (HTTP::Headers::Util::split_header_words(@_)) { + if (!defined($_->[1])) { + # this is a new auth scheme + push(@ret, shift(@$_) => {}); + shift @$_; + } + if (@ret) { + # this a new parameter pair for the last auth scheme + while (@$_) { + my $k = shift @$_; + my $v = shift @$_; + $ret[-1]{$k} = $v; + } + } + else { + # something wrong, parameter pair without any scheme seen + # IGNORE + } + } + @ret; +} + +sub _authenticate +{ + my $self = shift; + my $header = shift; + my @old = $self->_header($header); + if (@_) { + $self->remove_header($header); + my @new = @_; + while (@new) { + my $a_scheme = shift(@new); + if ($a_scheme =~ /\s/) { + # assume complete valid value, pass it through + $self->push_header($header, $a_scheme); + } + else { + my @param; + if (@new) { + my $p = $new[0]; + if (ref($p) eq "ARRAY") { + @param = @$p; + shift(@new); + } + elsif (ref($p) eq "HASH") { + @param = %$p; + shift(@new); + } + } + my $val = ucfirst(lc($a_scheme)); + if (@param) { + my $sep = " "; + while (@param) { + my $k = shift @param; + my $v = shift @param; + if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") { + # must quote the value + $v =~ s,([\\\"]),\\$1,g; + $v = qq("$v"); + } + $val .= "$sep$k=$v"; + $sep = ", "; + } + } + $self->push_header($header, $val); + } + } + } + return unless defined wantarray; + wantarray ? _parse_authenticate(@old) : join(", ", @old); +} + + +sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) } +sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) } + +1; diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm new file mode 100644 index 00000000000..743da463de4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm @@ -0,0 +1,94 @@ +package HTTP::Headers::ETag; + +use strict; +use vars qw($VERSION); +$VERSION = "5.810"; + +require HTTP::Date; + +require HTTP::Headers; +package HTTP::Headers; + +sub _etags +{ + my $self = shift; + my $header = shift; + my @old = _split_etag_list($self->_header($header)); + if (@_) { + $self->_header($header => join(", ", _split_etag_list(@_))); + } + wantarray ? @old : join(", ", @old); +} + +sub etag { shift->_etags("ETag", @_); } +sub if_match { shift->_etags("If-Match", @_); } +sub if_none_match { shift->_etags("If-None-Match", @_); } + +sub if_range { + # Either a date or an entity-tag + my $self = shift; + my @old = $self->_header("If-Range"); + if (@_) { + my $new = shift; + if (!defined $new) { + $self->remove_header("If-Range"); + } + elsif ($new =~ /^\d+$/) { + $self->_date_header("If-Range", $new); + } + else { + $self->_etags("If-Range", $new); + } + } + return unless defined(wantarray); + for (@old) { + my $t = HTTP::Date::str2time($_); + $_ = $t if $t; + } + wantarray ? @old : join(", ", @old); +} + + +# Split a list of entity tag values. The return value is a list +# consisting of one element per entity tag. Suitable for parsing +# headers like C<If-Match>, C<If-None-Match>. You might even want to +# use it on C<ETag> and C<If-Range> entity tag values, because it will +# normalize them to the common form. +# +# entity-tag = [ weak ] opaque-tag +# weak = "W/" +# opaque-tag = quoted-string + + +sub _split_etag_list +{ + my(@val) = @_; + my @res; + for (@val) { + while (length) { + my $weak = ""; + $weak = "W/" if s,^\s*[wW]/,,; + my $etag = ""; + if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) { + push(@res, "$weak$1"); + } + elsif (s/^\s*,//) { + push(@res, qq(W/"")) if $weak; + } + elsif (s/^\s*([^,\s]+)//) { + $etag = $1; + $etag =~ s/([\"\\])/\\$1/g; + push(@res, qq($weak"$etag")); + } + elsif (s/^\s+// || !length) { + push(@res, qq(W/"")) if $weak; + } + else { + die "This should not happen: '$_'"; + } + } + } + @res; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm new file mode 100644 index 00000000000..9ae65e7faf5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm @@ -0,0 +1,199 @@ +package HTTP::Headers::Util; + +use strict; +use vars qw($VERSION @ISA @EXPORT_OK); + +$VERSION = "5.817"; + +require Exporter; +@ISA=qw(Exporter); + +@EXPORT_OK=qw(split_header_words _split_header_words join_header_words); + + + +sub split_header_words { + my @res = &_split_header_words; + for my $arr (@res) { + for (my $i = @$arr - 2; $i >= 0; $i -= 2) { + $arr->[$i] = lc($arr->[$i]); + } + } + return @res; +} + +sub _split_header_words +{ + my(@val) = @_; + my @res; + for (@val) { + my @cur; + while (length) { + if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' + push(@cur, $1); + # a quoted value + if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { + my $val = $1; + $val =~ s/\\(.)/$1/g; + push(@cur, $val); + # some unquoted value + } + elsif (s/^\s*=\s*([^;,\s]*)//) { + my $val = $1; + $val =~ s/\s+$//; + push(@cur, $val); + # no value, a lone token + } + else { + push(@cur, undef); + } + } + elsif (s/^\s*,//) { + push(@res, [@cur]) if @cur; + @cur = (); + } + elsif (s/^\s*;// || s/^\s+//) { + # continue + } + else { + die "This should not happen: '$_'"; + } + } + push(@res, \@cur) if @cur; + } + @res; +} + + +sub join_header_words +{ + @_ = ([@_]) if @_ && !ref($_[0]); + my @res; + for (@_) { + my @cur = @$_; + my @attr; + while (@cur) { + my $k = shift @cur; + my $v = shift @cur; + if (defined $v) { + if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) { + $v =~ s/([\"\\])/\\$1/g; # escape " and \ + $k .= qq(="$v"); + } + else { + # token + $k .= "=$v"; + } + } + push(@attr, $k); + } + push(@res, join("; ", @attr)) if @attr; + } + join(", ", @res); +} + + +1; + +__END__ + +=head1 NAME + +HTTP::Headers::Util - Header value parsing utility functions + +=head1 SYNOPSIS + + use HTTP::Headers::Util qw(split_header_words); + @values = split_header_words($h->header("Content-Type")); + +=head1 DESCRIPTION + +This module provides a few functions that helps parsing and +construction of valid HTTP header values. None of the functions are +exported by default. + +The following functions are available: + +=over 4 + + +=item split_header_words( @header_values ) + +This function will parse the header values given as argument into a +list of anonymous arrays containing key/value pairs. The function +knows how to deal with ",", ";" and "=" as well as quoted values after +"=". A list of space separated tokens are parsed as if they were +separated by ";". + +If the @header_values passed as argument contains multiple values, +then they are treated as if they were a single value separated by +comma ",". + +This means that this function is useful for parsing header fields that +follow this syntax (BNF as from the HTTP/1.1 specification, but we relax +the requirement for tokens). + + headers = #header + header = (token | parameter) *( [";"] (token | parameter)) + + token = 1*<any CHAR except CTLs or separators> + separators = "(" | ")" | "<" | ">" | "@" + | "," | ";" | ":" | "\" | <"> + | "/" | "[" | "]" | "?" | "=" + | "{" | "}" | SP | HT + + quoted-string = ( <"> *(qdtext | quoted-pair ) <"> ) + qdtext = <any TEXT except <">> + quoted-pair = "\" CHAR + + parameter = attribute "=" value + attribute = token + value = token | quoted-string + +Each I<header> is represented by an anonymous array of key/value +pairs. The keys will be all be forced to lower case. +The value for a simple token (not part of a parameter) is C<undef>. +Syntactically incorrect headers will not necessary be parsed as you +would want. + +This is easier to describe with some examples: + + split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz'); + split_header_words('text/html; charset="iso-8859-1"'); + split_header_words('Basic realm="\\"foo\\\\bar\\""'); + +will return + + [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ] + ['text/html' => undef, charset => 'iso-8859-1'] + [basic => undef, realm => "\"foo\\bar\""] + +If you don't want the function to convert tokens and attribute keys to +lower case you can call it as C<_split_header_words> instead (with a +leading underscore). + +=item join_header_words( @arrays ) + +This will do the opposite of the conversion done by split_header_words(). +It takes a list of anonymous arrays as arguments (or a list of +key/value pairs) and produces a single header value. Attribute values +are quoted if needed. + +Example: + + join_header_words(["text/plain" => undef, charset => "iso-8859/1"]); + join_header_words("text/plain" => undef, charset => "iso-8859/1"); + +will both return the string: + + text/plain; charset="iso-8859/1" + +=back + +=head1 COPYRIGHT + +Copyright 1997-1998, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/HTTP/Message.pm b/Master/tlpkg/tlperl/lib/HTTP/Message.pm new file mode 100644 index 00000000000..944e88d1899 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Message.pm @@ -0,0 +1,1102 @@ +package HTTP::Message; + +use strict; +use vars qw($VERSION $AUTOLOAD); +$VERSION = "5.837"; + +require HTTP::Headers; +require Carp; + +my $CRLF = "\015\012"; # "\r\n" is not portable +$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI"; +eval "require $HTTP::URI_CLASS"; die $@ if $@; + +*_utf8_downgrade = defined(&utf8::downgrade) ? + sub { + utf8::downgrade($_[0], 1) or + Carp::croak("HTTP::Message content must be bytes") + } + : + sub { + }; + +sub new +{ + my($class, $header, $content) = @_; + if (defined $header) { + Carp::croak("Bad header argument") unless ref $header; + if (ref($header) eq "ARRAY") { + $header = HTTP::Headers->new(@$header); + } + else { + $header = $header->clone; + } + } + else { + $header = HTTP::Headers->new; + } + if (defined $content) { + _utf8_downgrade($content); + } + else { + $content = ''; + } + + bless { + '_headers' => $header, + '_content' => $content, + }, $class; +} + + +sub parse +{ + my($class, $str) = @_; + + my @hdr; + while (1) { + if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) { + push(@hdr, $1, $2); + $hdr[-1] =~ s/\r\z//; + } + elsif (@hdr && $str =~ s/^([ \t].*)\n?//) { + $hdr[-1] .= "\n$1"; + $hdr[-1] =~ s/\r\z//; + } + else { + $str =~ s/^\r?\n//; + last; + } + } + local $HTTP::Headers::TRANSLATE_UNDERSCORE; + new($class, \@hdr, $str); +} + + +sub clone +{ + my $self = shift; + my $clone = HTTP::Message->new($self->headers, + $self->content); + $clone->protocol($self->protocol); + $clone; +} + + +sub clear { + my $self = shift; + $self->{_headers}->clear; + $self->content(""); + delete $self->{_parts}; + return; +} + + +sub protocol { + shift->_elem('_protocol', @_); +} + +sub headers { + my $self = shift; + + # recalculation of _content might change headers, so we + # need to force it now + $self->_content unless exists $self->{_content}; + + $self->{_headers}; +} + +sub headers_as_string { + shift->headers->as_string(@_); +} + + +sub content { + + my $self = $_[0]; + if (defined(wantarray)) { + $self->_content unless exists $self->{_content}; + my $old = $self->{_content}; + $old = $$old if ref($old) eq "SCALAR"; + &_set_content if @_ > 1; + return $old; + } + + if (@_ > 1) { + &_set_content; + } + else { + Carp::carp("Useless content call in void context") if $^W; + } +} + + +sub _set_content { + my $self = $_[0]; + _utf8_downgrade($_[1]); + if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") { + ${$self->{_content}} = $_[1]; + } + else { + die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR"; + $self->{_content} = $_[1]; + delete $self->{_content_ref}; + } + delete $self->{_parts} unless $_[2]; +} + + +sub add_content +{ + my $self = shift; + $self->_content unless exists $self->{_content}; + my $chunkref = \$_[0]; + $chunkref = $$chunkref if ref($$chunkref); # legacy + + _utf8_downgrade($$chunkref); + + my $ref = ref($self->{_content}); + if (!$ref) { + $self->{_content} .= $$chunkref; + } + elsif ($ref eq "SCALAR") { + ${$self->{_content}} .= $$chunkref; + } + else { + Carp::croak("Can't append to $ref content"); + } + delete $self->{_parts}; +} + +sub add_content_utf8 { + my($self, $buf) = @_; + utf8::upgrade($buf); + utf8::encode($buf); + $self->add_content($buf); +} + +sub content_ref +{ + my $self = shift; + $self->_content unless exists $self->{_content}; + delete $self->{_parts}; + my $old = \$self->{_content}; + my $old_cref = $self->{_content_ref}; + if (@_) { + my $new = shift; + Carp::croak("Setting content_ref to a non-ref") unless ref($new); + delete $self->{_content}; # avoid modifying $$old + $self->{_content} = $new; + $self->{_content_ref}++; + } + $old = $$old if $old_cref; + return $old; +} + + +sub content_charset +{ + my $self = shift; + if (my $charset = $self->content_type_charset) { + return $charset; + } + + # time to start guessing + my $cref = $self->decoded_content(ref => 1, charset => "none"); + + # Unicode BOM + for ($$cref) { + return "UTF-8" if /^\xEF\xBB\xBF/; + return "UTF-32-LE" if /^\xFF\xFE\x00\x00/; + return "UTF-32-BE" if /^\x00\x00\xFE\xFF/; + return "UTF-16-LE" if /^\xFF\xFE/; + return "UTF-16-BE" if /^\xFE\xFF/; + } + + if ($self->content_is_xml) { + # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing + # XML entity not accompanied by external encoding information and not + # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration, + # in which the first characters must be '<?xml' + for ($$cref) { + return "UTF-32-BE" if /^\x00\x00\x00</; + return "UTF-32-LE" if /^<\x00\x00\x00/; + return "UTF-16-BE" if /^(?:\x00\s)*\x00</; + return "UTF-16-LE" if /^(?:\s\x00)*<\x00/; + if (/^\s*(<\?xml[^\x00]*?\?>)/) { + if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) { + my $enc = $2; + $enc =~ s/^\s+//; $enc =~ s/\s+\z//; + return $enc if $enc; + } + } + } + return "UTF-8"; + } + elsif ($self->content_is_html) { + # look for <META charset="..."> or <META content="..."> + # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding + my $charset; + require HTML::Parser; + my $p = HTML::Parser->new( + start_h => [sub { + my($tag, $attr, $self) = @_; + $charset = $attr->{charset}; + unless ($charset) { + # look at $attr->{content} ... + if (my $c = $attr->{content}) { + require HTTP::Headers::Util; + my @v = HTTP::Headers::Util::split_header_words($c); + return unless @v; + my($ct, undef, %ct_param) = @{$v[0]}; + $charset = $ct_param{charset}; + } + return unless $charset; + } + if ($charset =~ /^utf-?16/i) { + # converted document, assume UTF-8 + $charset = "UTF-8"; + } + $self->eof; + }, "tagname, attr, self"], + report_tags => [qw(meta)], + utf8_mode => 1, + ); + $p->parse($$cref); + return $charset if $charset; + } + if ($self->content_type =~ /^text\//) { + for ($$cref) { + if (length) { + return "US-ASCII" unless /[\x80-\xFF]/; + require Encode; + eval { + Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC()); + }; + return "UTF-8" unless $@; + return "ISO-8859-1"; + } + } + } + + return undef; +} + + +sub decoded_content +{ + my($self, %opt) = @_; + my $content_ref; + my $content_ref_iscopy; + + eval { + $content_ref = $self->content_ref; + die "Can't decode ref content" if ref($content_ref) ne "SCALAR"; + + if (my $h = $self->header("Content-Encoding")) { + $h =~ s/^\s+//; + $h =~ s/\s+$//; + for my $ce (reverse split(/\s*,\s*/, lc($h))) { + next unless $ce; + next if $ce eq "identity"; + if ($ce eq "gzip" || $ce eq "x-gzip") { + require IO::Uncompress::Gunzip; + my $output; + IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0) + or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ($ce eq "x-bzip2") { + require IO::Uncompress::Bunzip2; + my $output; + IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0) + or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error"; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ($ce eq "deflate") { + require IO::Uncompress::Inflate; + my $output; + my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0); + my $error = $IO::Uncompress::Inflate::InflateError; + unless ($status) { + # "Content-Encoding: deflate" is supposed to mean the + # "zlib" format of RFC 1950, but Microsoft got that + # wrong, so some servers sends the raw compressed + # "deflate" data. This tries to inflate this format. + $output = undef; + require IO::Uncompress::RawInflate; + unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) { + $self->push_header("Client-Warning" => + "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError"); + $output = undef; + } + } + die "Can't inflate content: $error" unless defined $output; + $content_ref = \$output; + $content_ref_iscopy++; + } + elsif ($ce eq "compress" || $ce eq "x-compress") { + die "Can't uncompress content"; + } + elsif ($ce eq "base64") { # not really C-T-E, but should be harmless + require MIME::Base64; + $content_ref = \MIME::Base64::decode($$content_ref); + $content_ref_iscopy++; + } + elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless + require MIME::QuotedPrint; + $content_ref = \MIME::QuotedPrint::decode($$content_ref); + $content_ref_iscopy++; + } + else { + die "Don't know how to decode Content-Encoding '$ce'"; + } + } + } + + if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) { + my $charset = lc( + $opt{charset} || + $self->content_type_charset || + $opt{default_charset} || + $self->content_charset || + "ISO-8859-1" + ); + unless ($charset =~ /^(?:none|us-ascii|iso-8859-1)\z/) { + require Encode; + if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 && + !$content_ref_iscopy) + { + # LEAVE_SRC did not work before Encode-2.0901 + my $copy = $$content_ref; + $content_ref = \$copy; + $content_ref_iscopy++; + } + eval { + $content_ref = \Encode::decode($charset, $$content_ref, + ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()); + }; + if ($@) { + my $retried; + if ($@ =~ /^Unknown encoding/) { + my $alt_charset = lc($opt{alt_charset} || ""); + if ($alt_charset && $charset ne $alt_charset) { + # Retry decoding with the alternative charset + $content_ref = \Encode::decode($alt_charset, $$content_ref, + ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()) + unless $alt_charset =~ /^(?:none|us-ascii|iso-8859-1)\z/; + $retried++; + } + } + die unless $retried; + } + die "Encode::decode() returned undef improperly" unless defined $$content_ref; + if ($is_xml) { + # Get rid of the XML encoding declaration if present + $$content_ref =~ s/^\x{FEFF}//; + if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) { + substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//; + } + } + } + } + }; + if ($@) { + Carp::croak($@) if $opt{raise_error}; + return undef; + } + + return $opt{ref} ? $content_ref : $$content_ref; +} + + +sub decodable +{ + # should match the Content-Encoding values that decoded_content can deal with + my $self = shift; + my @enc; + # XXX preferably we should determine if the modules are available without loading + # them here + eval { + require IO::Uncompress::Gunzip; + push(@enc, "gzip", "x-gzip"); + }; + eval { + require IO::Uncompress::Inflate; + require IO::Uncompress::RawInflate; + push(@enc, "deflate"); + }; + eval { + require IO::Uncompress::Bunzip2; + push(@enc, "x-bzip2"); + }; + # we don't care about announcing the 'identity', 'base64' and + # 'quoted-printable' stuff + return wantarray ? @enc : join(", ", @enc); +} + + +sub decode +{ + my $self = shift; + return 1 unless $self->header("Content-Encoding"); + if (defined(my $content = $self->decoded_content(charset => "none"))) { + $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5"); + $self->content($content); + return 1; + } + return 0; +} + + +sub encode +{ + my($self, @enc) = @_; + + Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,; + Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,; + + return 1 unless @enc; # nothing to do + + my $content = $self->content; + for my $encoding (@enc) { + if ($encoding eq "identity") { + # nothing to do + } + elsif ($encoding eq "base64") { + require MIME::Base64; + $content = MIME::Base64::encode($content); + } + elsif ($encoding eq "gzip" || $encoding eq "x-gzip") { + require IO::Compress::Gzip; + my $output; + IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1) + or die "Can't gzip content: $IO::Compress::Gzip::GzipError"; + $content = $output; + } + elsif ($encoding eq "deflate") { + require IO::Compress::Deflate; + my $output; + IO::Compress::Deflate::deflate(\$content, \$output) + or die "Can't deflate content: $IO::Compress::Deflate::DeflateError"; + $content = $output; + } + elsif ($encoding eq "x-bzip2") { + require IO::Compress::Bzip2; + my $output; + IO::Compress::Bzip2::bzip2(\$content, \$output) + or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error"; + $content = $output; + } + elsif ($encoding eq "rot13") { # for the fun of it + $content =~ tr/A-Za-z/N-ZA-Mn-za-m/; + } + else { + return 0; + } + } + my $h = $self->header("Content-Encoding"); + unshift(@enc, $h) if $h; + $self->header("Content-Encoding", join(", ", @enc)); + $self->remove_header("Content-Length", "Content-MD5"); + $self->content($content); + return 1; +} + + +sub as_string +{ + my($self, $eol) = @_; + $eol = "\n" unless defined $eol; + + # The calculation of content might update the headers + # so we need to do that first. + my $content = $self->content; + + return join("", $self->{'_headers'}->as_string($eol), + $eol, + $content, + (@_ == 1 && length($content) && + $content !~ /\n\z/) ? "\n" : "", + ); +} + + +sub dump +{ + my($self, %opt) = @_; + my $content = $self->content; + my $chopped = 0; + if (!ref($content)) { + my $maxlen = $opt{maxlength}; + $maxlen = 512 unless defined($maxlen); + if ($maxlen && length($content) > $maxlen * 1.1 + 3) { + $chopped = length($content) - $maxlen; + $content = substr($content, 0, $maxlen) . "..."; + } + + $content =~ s/\\/\\\\/g; + $content =~ s/\t/\\t/g; + $content =~ s/\r/\\r/g; + + # no need for 3 digits in escape for these + $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; + + $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; + $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg; + + # remaining whitespace + $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg; + $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg; + $content =~ s/\n\z/\\n/; + + my $no_content = "(no content)"; + if ($content eq $no_content) { + # escape our $no_content marker + $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg; + } + elsif ($content eq "") { + $content = "(no content)"; + } + } + + my @dump; + push(@dump, $opt{preheader}) if $opt{preheader}; + push(@dump, $self->{_headers}->as_string, $content); + push(@dump, "(+ $chopped more bytes not shown)") if $chopped; + + my $dump = join("\n", @dump, ""); + $dump =~ s/^/$opt{prefix}/gm if $opt{prefix}; + + print $dump unless defined wantarray; + return $dump; +} + + +sub parts { + my $self = shift; + if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) { + $self->_parts; + } + my $old = $self->{_parts}; + if (@_) { + my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; + my $ct = $self->content_type || ""; + if ($ct =~ m,^message/,) { + Carp::croak("Only one part allowed for $ct content") + if @parts > 1; + } + elsif ($ct !~ m,^multipart/,) { + $self->remove_content_headers; + $self->content_type("multipart/mixed"); + } + $self->{_parts} = \@parts; + _stale_content($self); + } + return @$old if wantarray; + return $old->[0]; +} + +sub add_part { + my $self = shift; + if (($self->content_type || "") !~ m,^multipart/,) { + my $p = HTTP::Message->new($self->remove_content_headers, + $self->content("")); + $self->content_type("multipart/mixed"); + $self->{_parts} = []; + if ($p->headers->header_field_names || $p->content ne "") { + push(@{$self->{_parts}}, $p); + } + } + elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") { + $self->_parts; + } + + push(@{$self->{_parts}}, @_); + _stale_content($self); + return; +} + +sub _stale_content { + my $self = shift; + if (ref($self->{_content}) eq "SCALAR") { + # must recalculate now + $self->_content; + } + else { + # just invalidate cache + delete $self->{_content}; + delete $self->{_content_ref}; + } +} + + +# delegate all other method calls the the headers object. +sub AUTOLOAD +{ + my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); + + # We create the function here so that it will not need to be + # autoloaded the next time. + no strict 'refs'; + *$method = sub { shift->headers->$method(@_) }; + goto &$method; +} + + +sub DESTROY {} # avoid AUTOLOADing it + + +# Private method to access members in %$self +sub _elem +{ + my $self = shift; + my $elem = shift; + my $old = $self->{$elem}; + $self->{$elem} = $_[0] if @_; + return $old; +} + + +# Create private _parts attribute from current _content +sub _parts { + my $self = shift; + my $ct = $self->content_type; + if ($ct =~ m,^multipart/,) { + require HTTP::Headers::Util; + my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type")); + die "Assert" unless @h; + my %h = @{$h[0]}; + if (defined(my $b = $h{boundary})) { + my $str = $self->content; + $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s; + if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) { + $self->{_parts} = [map HTTP::Message->parse($_), + split(/\r?\n--\Q$b\E\r?\n/, $str)] + } + } + } + elsif ($ct eq "message/http") { + require HTTP::Request; + require HTTP::Response; + my $content = $self->content; + my $class = ($content =~ m,^(HTTP/.*)\n,) ? + "HTTP::Response" : "HTTP::Request"; + $self->{_parts} = [$class->parse($content)]; + } + elsif ($ct =~ m,^message/,) { + $self->{_parts} = [ HTTP::Message->parse($self->content) ]; + } + + $self->{_parts} ||= []; +} + + +# Create private _content attribute from current _parts +sub _content { + my $self = shift; + my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed"; + if ($ct =~ m,^\s*message/,i) { + _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1); + return; + } + + require HTTP::Headers::Util; + my @v = HTTP::Headers::Util::split_header_words($ct); + Carp::carp("Multiple Content-Type headers") if @v > 1; + @v = @{$v[0]}; + + my $boundary; + my $boundary_index; + for (my @tmp = @v; @tmp;) { + my($k, $v) = splice(@tmp, 0, 2); + if ($k eq "boundary") { + $boundary = $v; + $boundary_index = @v - @tmp - 1; + last; + } + } + + my @parts = map $_->as_string($CRLF), @{$self->{_parts}}; + + my $bno = 0; + $boundary = _boundary() unless defined $boundary; + CHECK_BOUNDARY: + { + for (@parts) { + if (index($_, $boundary) >= 0) { + # must have a better boundary + $boundary = _boundary(++$bno); + redo CHECK_BOUNDARY; + } + } + } + + if ($boundary_index) { + $v[$boundary_index] = $boundary; + } + else { + push(@v, boundary => $boundary); + } + + $ct = HTTP::Headers::Util::join_header_words(@v); + $self->{_headers}->header("Content-Type", $ct); + + _set_content($self, "--$boundary$CRLF" . + join("$CRLF--$boundary$CRLF", @parts) . + "$CRLF--$boundary--$CRLF", + 1); +} + + +sub _boundary +{ + my $size = shift || return "xYzZY"; + require MIME::Base64; + my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); + $b =~ s/[\W]/X/g; # ensure alnum only + $b; +} + + +1; + + +__END__ + +=head1 NAME + +HTTP::Message - HTTP style message (base class) + +=head1 SYNOPSIS + + use base 'HTTP::Message'; + +=head1 DESCRIPTION + +An C<HTTP::Message> object contains some headers and a content body. +The following methods are available: + +=over 4 + +=item $mess = HTTP::Message->new + +=item $mess = HTTP::Message->new( $headers ) + +=item $mess = HTTP::Message->new( $headers, $content ) + +This constructs a new message object. Normally you would want +construct C<HTTP::Request> or C<HTTP::Response> objects instead. + +The optional $header argument should be a reference to an +C<HTTP::Headers> object or a plain array reference of key/value pairs. +If an C<HTTP::Headers> object is provided then a copy of it will be +embedded into the constructed message, i.e. it will not be owned and +can be modified afterwards without affecting the message. + +The optional $content argument should be a string of bytes. + +=item $mess = HTTP::Message->parse( $str ) + +This constructs a new message object by parsing the given string. + +=item $mess->headers + +Returns the embedded C<HTTP::Headers> object. + +=item $mess->headers_as_string + +=item $mess->headers_as_string( $eol ) + +Call the as_string() method for the headers in the +message. This will be the same as + + $mess->headers->as_string + +but it will make your program a whole character shorter :-) + +=item $mess->content + +=item $mess->content( $bytes ) + +The content() method sets the raw content if an argument is given. If no +argument is given the content is not touched. In either case the +original raw content is returned. + +Note that the content should be a string of bytes. Strings in perl +can contain characters outside the range of a byte. The C<Encode> +module can be used to turn such strings into a string of bytes. + +=item $mess->add_content( $bytes ) + +The add_content() methods appends more data bytes to the end of the +current content buffer. + +=item $mess->add_content_utf8( $string ) + +The add_content_utf8() method appends the UTF-8 bytes representing the +string to the end of the current content buffer. + +=item $mess->content_ref + +=item $mess->content_ref( \$bytes ) + +The content_ref() method will return a reference to content buffer string. +It can be more efficient to access the content this way if the content +is huge, and it can even be used for direct manipulation of the content, +for instance: + + ${$res->content_ref} =~ s/\bfoo\b/bar/g; + +This example would modify the content buffer in-place. + +If an argument is passed it will setup the content to reference some +external source. The content() and add_content() methods +will automatically dereference scalar references passed this way. For +other references content() will return the reference itself and +add_content() will refuse to do anything. + +=item $mess->content_charset + +This returns the charset used by the content in the message. The +charset is either found as the charset attribute of the +C<Content-Type> header or by guessing. + +See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding> +for details about how charset is determined. + +=item $mess->decoded_content( %options ) + +Returns the content with any C<Content-Encoding> undone and the raw +content encoded to perl's Unicode strings. If the C<Content-Encoding> +or C<charset> of the message is unknown this method will fail by +returning C<undef>. + +The following options can be specified. + +=over + +=item C<charset> + +This override the charset parameter for text content. The value +C<none> can used to suppress decoding of the charset. + +=item C<default_charset> + +This override the default charset guessed by content_charset() or +if that fails "ISO-8859-1". + +=item C<alt_charset> + +If decoding fails because the charset specified in the Content-Type header +isn't recognized by Perl's Encode module, then try decoding using this charset +instead of failing. The C<alt_charset> might be specified as C<none> to simply +return the string without any decoding of charset as alternative. + +=item C<charset_strict> + +Abort decoding if malformed characters is found in the content. By +default you get the substitution character ("\x{FFFD}") in place of +malformed characters. + +=item C<raise_error> + +If TRUE then raise an exception if not able to decode content. Reason +might be that the specified C<Content-Encoding> or C<charset> is not +supported. If this option is FALSE, then decoded_content() will return +C<undef> on errors, but will still set $@. + +=item C<ref> + +If TRUE then a reference to decoded content is returned. This might +be more efficient in cases where the decoded content is identical to +the raw content as no data copying is required in this case. + +=back + +=item $mess->decodable + +=item HTTP::Message::decodable() + +This returns the encoding identifiers that decoded_content() can +process. In scalar context returns a comma separated string of +identifiers. + +This value is suitable for initializing the C<Accept-Encoding> request +header field. + +=item $mess->decode + +This method tries to replace the content of the message with the +decoded version and removes the C<Content-Encoding> header. Returns +TRUE if successful and FALSE if not. + +If the message does not have a C<Content-Encoding> header this method +does nothing and returns TRUE. + +Note that the content of the message is still bytes after this method +has been called and you still need to call decoded_content() if you +want to process its content as a string. + +=item $mess->encode( $encoding, ... ) + +Apply the given encodings to the content of the message. Returns TRUE +if successful. The "identity" (non-)encoding is always supported; other +currently supported encodings, subject to availability of required +additional modules, are "gzip", "deflate", "x-bzip2" and "base64". + +A successful call to this function will set the C<Content-Encoding> +header. + +Note that C<multipart/*> or C<message/*> messages can't be encoded and +this method will croak if you try. + +=item $mess->parts + +=item $mess->parts( @parts ) + +=item $mess->parts( \@parts ) + +Messages can be composite, i.e. contain other messages. The composite +messages have a content type of C<multipart/*> or C<message/*>. This +method give access to the contained messages. + +The argumentless form will return a list of C<HTTP::Message> objects. +If the content type of $msg is not C<multipart/*> or C<message/*> then +this will return the empty list. In scalar context only the first +object is returned. The returned message parts should be regarded as +read-only (future versions of this library might make it possible +to modify the parent by modifying the parts). + +If the content type of $msg is C<message/*> then there will only be +one part returned. + +If the content type is C<message/http>, then the return value will be +either an C<HTTP::Request> or an C<HTTP::Response> object. + +If an @parts argument is given, then the content of the message will be +modified. The array reference form is provided so that an empty list +can be provided. The @parts array should contain C<HTTP::Message> +objects. The @parts objects are owned by $mess after this call and +should not be modified or made part of other messages. + +When updating the message with this method and the old content type of +$mess is not C<multipart/*> or C<message/*>, then the content type is +set to C<multipart/mixed> and all other content headers are cleared. + +This method will croak if the content type is C<message/*> and more +than one part is provided. + +=item $mess->add_part( $part ) + +This will add a part to a message. The $part argument should be +another C<HTTP::Message> object. If the previous content type of +$mess is not C<multipart/*> then the old content (together with all +content headers) will be made part #1 and the content type made +C<multipart/mixed> before the new part is added. The $part object is +owned by $mess after this call and should not be modified or made part +of other messages. + +There is no return value. + +=item $mess->clear + +Will clear the headers and set the content to the empty string. There +is no return value + +=item $mess->protocol + +=item $mess->protocol( $proto ) + +Sets the HTTP protocol used for the message. The protocol() is a string +like C<HTTP/1.0> or C<HTTP/1.1>. + +=item $mess->clone + +Returns a copy of the message object. + +=item $mess->as_string + +=item $mess->as_string( $eol ) + +Returns the message formatted as a single string. + +The optional $eol parameter specifies the line ending sequence to use. +The default is "\n". If no $eol is given then as_string will ensure +that the returned string is newline terminated (even when the message +content is not). No extra newline is appended if an explicit $eol is +passed. + +=item $mess->dump( %opt ) + +Returns the message formatted as a string. In void context print the string. + +This differs from C<< $mess->as_string >> in that it escapes the bytes +of the content so that it's safe to print them and it limits how much +content to print. The escapes syntax used is the same as for Perl's +double quoted strings. If there is no content the string "(no +content)" is shown in its place. + +Options to influence the output can be passed as key/value pairs. The +following options are recognized: + +=over + +=item maxlength => $num + +How much of the content to show. The default is 512. Set this to 0 +for unlimited. + +If the content is longer then the string is chopped at the limit and +the string "...\n(### more bytes not shown)" appended. + +=item prefix => $str + +A string that will be prefixed to each line of the dump. + +=back + +=back + +All methods unknown to C<HTTP::Message> itself are delegated to the +C<HTTP::Headers> object that is part of every message. This allows +convenient access to these methods. Refer to L<HTTP::Headers> for +details of these methods: + + $mess->header( $field => $val ) + $mess->push_header( $field => $val ) + $mess->init_header( $field => $val ) + $mess->remove_header( $field ) + $mess->remove_content_headers + $mess->header_field_names + $mess->scan( \&doit ) + + $mess->date + $mess->expires + $mess->if_modified_since + $mess->if_unmodified_since + $mess->last_modified + $mess->content_type + $mess->content_encoding + $mess->content_length + $mess->content_language + $mess->title + $mess->user_agent + $mess->server + $mess->from + $mess->referer + $mess->www_authenticate + $mess->authorization + $mess->proxy_authorization + $mess->authorization_basic + $mess->proxy_authorization_basic + +=head1 COPYRIGHT + +Copyright 1995-2004 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm b/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm new file mode 100644 index 00000000000..7ded7e6d5a5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm @@ -0,0 +1,529 @@ +package HTTP::Negotiate; + +$VERSION = "5.835"; +sub Version { $VERSION; } + +require 5.002; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(choose); + +require HTTP::Headers; + +$DEBUG = 0; + +sub choose ($;$) +{ + my($variants, $request) = @_; + my(%accept); + + unless (defined $request) { + # Create a request object from the CGI environment variables + $request = HTTP::Headers->new; + $request->header('Accept', $ENV{HTTP_ACCEPT}) + if $ENV{HTTP_ACCEPT}; + $request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET}) + if $ENV{HTTP_ACCEPT_CHARSET}; + $request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING}) + if $ENV{HTTP_ACCEPT_ENCODING}; + $request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE}) + if $ENV{HTTP_ACCEPT_LANGUAGE}; + } + + # Get all Accept values from the request. Build a hash initialized + # like this: + # + # %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 }, + # 'audio/basic' => { q => 1 }, + # }, + # language => { 'no' => { q => 1 }, + # } + # ); + + $request->scan(sub { + my($key, $val) = @_; + + my $type; + if ($key =~ s/^Accept-//) { + $type = lc($key); + } + elsif ($key eq "Accept") { + $type = "type"; + } + else { + return; + } + + $val =~ s/\s+//g; + my $default_q = 1; + for my $name (split(/,/, $val)) { + my(%param, $param); + if ($name =~ s/;(.*)//) { + for $param (split(/;/, $1)) { + my ($pk, $pv) = split(/=/, $param, 2); + $param{lc $pk} = $pv; + } + } + $name = lc $name; + if (defined $param{'q'}) { + $param{'q'} = 1 if $param{'q'} > 1; + $param{'q'} = 0 if $param{'q'} < 0; + } + else { + $param{'q'} = $default_q; + + # This makes sure that the first ones are slightly better off + # and therefore more likely to be chosen. + $default_q -= 0.0001; + } + $accept{$type}{$name} = \%param; + } + }); + + # Check if any of the variants specify a language. We do this + # because it influences how we treat those without (they default to + # 0.5 instead of 1). + my $any_lang = 0; + for $var (@$variants) { + if ($var->[5]) { + $any_lang = 1; + last; + } + } + + if ($DEBUG) { + print "Negotiation parameters in the request\n"; + for $type (keys %accept) { + print " $type:\n"; + for $name (keys %{$accept{$type}}) { + print " $name\n"; + for $pv (keys %{$accept{$type}{$name}}) { + print " $pv = $accept{$type}{$name}{$pv}\n"; + } + } + } + } + + my @Q = (); # This is where we collect the results of the + # quality calculations + + # Calculate quality for all the variants that are available. + for (@$variants) { + my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_; + $qs = 1 unless defined $qs; + $ct = '' unless defined $ct; + $bs = 0 unless defined $bs; + $lang = lc($lang) if $lang; # lg tags are always case-insensitive + if ($DEBUG) { + print "\nEvaluating $id (ct='$ct')\n"; + printf " qs = %.3f\n", $qs; + print " enc = $enc\n" if $enc && !ref($enc); + print " enc = @$enc\n" if $enc && ref($enc); + print " cs = $cs\n" if $cs; + print " lang = $lang\n" if $lang; + print " bs = $bs\n" if $bs; + } + + # Calculate encoding quality + my $qe = 1; + # If the variant has no assigned Content-Encoding, or if no + # Accept-Encoding field is present, then the value assigned + # is "qe=1". If *all* of the variant's content encodings + # are listed in the Accept-Encoding field, then the value + # assigned is "qw=1". If *any* of the variant's content + # encodings are not listed in the provided Accept-Encoding + # field, then the value assigned is "qe=0" + if (exists $accept{'encoding'} && $enc) { + my @enc = ref($enc) ? @$enc : ($enc); + for (@enc) { + print "Is encoding $_ accepted? " if $DEBUG; + unless(exists $accept{'encoding'}{$_}) { + print "no\n" if $DEBUG; + $qe = 0; + last; + } + else { + print "yes\n" if $DEBUG; + } + } + } + + # Calculate charset quality + my $qc = 1; + # If the variant's media-type has no charset parameter, + # or the variant's charset is US-ASCII, or if no Accept-Charset + # field is present, then the value assigned is "qc=1". If the + # variant's charset is listed in the Accept-Charset field, + # then the value assigned is "qc=1. Otherwise, if the variant's + # charset is not listed in the provided Accept-Encoding field, + # then the value assigned is "qc=0". + if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) { + $qc = 0 unless $accept{'charset'}{$cs}; + } + + # Calculate language quality + my $ql = 1; + if ($lang && exists $accept{'language'}) { + my @lang = ref($lang) ? @$lang : ($lang); + # If any of the variant's content languages are listed + # in the Accept-Language field, the the value assigned is + # the largest of the "q" parameter values for those language + # tags. + my $q = undef; + for (@lang) { + next unless exists $accept{'language'}{$_}; + my $this_q = $accept{'language'}{$_}{'q'}; + $q = $this_q unless defined $q; + $q = $this_q if $this_q > $q; + } + if(defined $q) { + $DEBUG and print " -- Exact language match at q=$q\n"; + } + else { + # If there was no exact match and at least one of + # the Accept-Language field values is a complete + # subtag prefix of the content language tag(s), then + # the "q" parameter value of the largest matching + # prefix is used. + $DEBUG and print " -- No exact language match\n"; + my $selected = undef; + for $al (keys %{ $accept{'language'} }) { + if (index($al, "$lang-") == 0) { + # $lang starting with $al isn't enough, or else + # Accept-Language: hu (Hungarian) would seem + # to accept a document in hup (Hupa) + $DEBUG and print " -- $al ISA $lang\n"; + $selected = $al unless defined $selected; + $selected = $al if length($al) > length($selected); + } + else { + $DEBUG and print " -- $lang isn't a $al\n"; + } + } + $q = $accept{'language'}{$selected}{'q'} if $selected; + + # If none of the variant's content language tags or + # tag prefixes are listed in the provided + # Accept-Language field, then the value assigned + # is "ql=0.001" + $q = 0.001 unless defined $q; + } + $ql = $q; + } + else { + $ql = 0.5 if $any_lang && exists $accept{'language'}; + } + + my $q = 1; + my $mbx = undef; + # If no Accept field is given, then the value assigned is "q=1". + # If at least one listed media range matches the variant's media + # type, then the "q" parameter value assigned to the most specific + # of those matched is used (e.g. "text/html;version=3.0" is more + # specific than "text/html", which is more specific than "text/*", + # which in turn is more specific than "*/*"). If not media range + # in the provided Accept field matches the variant's media type, + # then the value assigned is "q=0". + if (exists $accept{'type'} && $ct) { + # First we clean up our content-type + $ct =~ s/\s+//g; + my $params = ""; + $params = $1 if $ct =~ s/;(.*)//; + my($type, $subtype) = split("/", $ct, 2); + my %param = (); + for $param (split(/;/, $params)) { + my($pk,$pv) = split(/=/, $param, 2); + $param{$pk} = $pv; + } + + my $sel_q = undef; + my $sel_mbx = undef; + my $sel_specificness = 0; + + ACCEPT_TYPE: + for $at (keys %{ $accept{'type'} }) { + print "Consider $at...\n" if $DEBUG; + my($at_type, $at_subtype) = split("/", $at, 2); + # Is it a match on the type + next if $at_type ne '*' && $at_type ne $type; + next if $at_subtype ne '*' && $at_subtype ne $subtype; + my $specificness = 0; + $specificness++ if $at_type ne '*'; + $specificness++ if $at_subtype ne '*'; + # Let's see if content-type parameters also match + while (($pk, $pv) = each %param) { + print "Check if $pk = $pv is true\n" if $DEBUG; + next unless exists $accept{'type'}{$at}{$pk}; + next ACCEPT_TYPE + unless $accept{'type'}{$at}{$pk} eq $pv; + print "yes it is!!\n" if $DEBUG; + $specificness++; + } + print "Hurray, type match with specificness = $specificness\n" + if $DEBUG; + + if (!defined($sel_q) || $sel_specificness < $specificness) { + $sel_q = $accept{'type'}{$at}{'q'}; + $sel_mbx = $accept{'type'}{$at}{'mbx'}; + $sel_specificness = $specificness; + } + } + $q = $sel_q || 0; + $mbx = $sel_mbx; + } + + my $Q; + if (!defined($mbx) || $mbx >= $bs) { + $Q = $qs * $qe * $qc * $ql * $q; + } + else { + $Q = 0; + print "Variant's size is too large ==> Q=0\n" if $DEBUG; + } + + if ($DEBUG) { + $mbx = "undef" unless defined $mbx; + printf "Q=%.4f", $Q; + print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n"; + } + + push(@Q, [$id, $Q, $bs]); + } + + + @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q; + + return @Q if wantarray; + return undef unless @Q; + return undef if $Q[0][1] == 0; + $Q[0][0]; +} + +1; + +__END__ + + +=head1 NAME + +HTTP::Negotiate - choose a variant to serve + +=head1 SYNOPSIS + + use HTTP::Negotiate qw(choose); + + # ID QS Content-Type Encoding Char-Set Lang Size + $variants = + [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000], + ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400], + ['var3', 0.3, 'image/gif', undef, undef, undef, 43555], + ]; + + @preferred = choose($variants, $request_headers); + $the_one = choose($variants); + +=head1 DESCRIPTION + +This module provides a complete implementation of the HTTP content +negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps> +chapter 12. Content negotiation allows for the selection of a +preferred content representation based upon attributes of the +negotiable variants and the value of the various Accept* header fields +in the request. + +The variants are ordered by preference by calling the function +choose(). + +The first parameter is reference to an array of the variants to +choose among. +Each element in this array is an array with the values [$id, $qs, +$content_type, $content_encoding, $charset, $content_language, +$content_length] whose meanings are described +below. The $content_encoding and $content_language can be either a +single scalar value or an array reference if there are several values. + +The second optional parameter is either a HTTP::Headers or a HTTP::Request +object which is searched for "Accept*" headers. If this +parameter is missing, then the accept specification is initialized +from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET, +HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE. + +In an array context, choose() returns a list of [variant +identifier, calculated quality, size] tuples. The values are sorted by +quality, highest quality first. If the calculated quality is the same +for two variants, then they are sorted by size (smallest first). I<E.g.>: + + (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]); + +Note that also zero quality variants are included in the return list +even if these should never be served to the client. + +In a scalar context, it returns the identifier of the variant with the +highest score or C<undef> if none have non-zero quality. + +If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of +noise is generated on STDOUT during evaluation of choose(). + +=head1 VARIANTS + +A variant is described by a list of the following values. If the +attribute does not make sense or is unknown for a variant, then use +C<undef> instead. + +=over 3 + +=item identifier + +This is a string that you use as the name for the variant. This +identifier for the preferred variants returned by choose(). + +=item qs + +This is a number between 0.000 and 1.000 that describes the "source +quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this +value: + +Source quality is measured by the content provider as representing the +amount of degradation from the original source. For example, a +picture in JPEG form would have a lower qs when translated to the XBM +format, and much lower qs when translated to an ASCII-art +representation. Note, however, that this is a function of the source +- an original piece of ASCII-art may degrade in quality if it is +captured in JPEG form. The qs values should be assigned to each +variant by the content provider; if no qs value has been assigned, the +default is generally "qs=1". + +=item content-type + +This is the media type of the variant. The media type does not +include a charset attribute, but might contain other parameters. +Examples are: + + text/html + text/html;version=2.0 + text/plain + image/gif + image/jpg + +=item content-encoding + +This is one or more content encodings that has been applied to the +variant. The content encoding is generally used as a modifier to the +content media type. The most common content encodings are: + + gzip + compress + +=item content-charset + +This is the character set used when the variant contains text. +The charset value should generally be C<undef> or one of these: + + us-ascii + iso-8859-1 ... iso-8859-9 + iso-2022-jp + iso-2022-jp-2 + iso-2022-kr + unicode-1-1 + unicode-1-1-utf-7 + unicode-1-1-utf-8 + +=item content-language + +This describes one or more languages that are used in the variant. +Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A +language is in this context a natural language spoken, written, or +otherwise conveyed by human beings for communication of information to +other human beings. Computer languages are explicitly excluded. + +The language tags are defined by RFC 3066. Examples +are: + + no Norwegian + en International English + en-US US English + en-cockney + +=item content-length + +This is the number of bytes used to represent the content. + +=back + +=head1 ACCEPT HEADERS + +The following Accept* headers can be used for describing content +preferences in a request (This description is an edited extract from +F<draft-ietf-http-v11-spec-00.ps>): + +=over 3 + +=item Accept + +This header can be used to indicate a list of media ranges which are +acceptable as a response to the request. The "*" character is used to +group media types into ranges, with "*/*" indicating all media types +and "type/*" indicating all subtypes of that type. + +The parameter q is used to indicate the quality factor, which +represents the user's preference for that range of media types. The +parameter mbx gives the maximum acceptable size of the response +content. The default values are: q=1 and mbx=infinity. If no Accept +header is present, then the client accepts all media types with q=1. + +For example: + + Accept: audio/*;q=0.2;mbx=200000, audio/basic + +would mean: "I prefer audio/basic (of any size), but send me any audio +type if it is the best available after an 80% mark-down in quality and +its size is less than 200000 bytes" + + +=item Accept-Charset + +Used to indicate what character sets are acceptable for the response. +The "us-ascii" character set is assumed to be acceptable for all user +agents. If no Accept-Charset field is given, the default is that any +charset is acceptable. Example: + + Accept-Charset: iso-8859-1, unicode-1-1 + + +=item Accept-Encoding + +Restricts the Content-Encoding values which are acceptable in the +response. If no Accept-Encoding field is present, the server may +assume that the client will accept any content encoding. An empty +Accept-Encoding means that no content encoding is acceptable. Example: + + Accept-Encoding: compress, gzip + + +=item Accept-Language + +This field is similar to Accept, but restricts the set of natural +languages that are preferred in a response. Each language may be +given an associated quality value which represents an estimate of the +user's comprehension of that language. For example: + + Accept-Language: no, en-gb;q=0.8, de;q=0.55 + +would mean: "I prefer Norwegian, but will accept British English (with +80% comprehension) or German (with 55% comprehension). + +=back + + +=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. + +=head1 AUTHOR + +Gisle Aas <gisle@aas.no> + +=cut diff --git a/Master/tlpkg/tlperl/lib/HTTP/Request.pm b/Master/tlpkg/tlperl/lib/HTTP/Request.pm new file mode 100644 index 00000000000..ac7dc65af43 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Request.pm @@ -0,0 +1,242 @@ +package HTTP::Request; + +require HTTP::Message; +@ISA = qw(HTTP::Message); +$VERSION = "5.827"; + +use strict; + + + +sub new +{ + my($class, $method, $uri, $header, $content) = @_; + my $self = $class->SUPER::new($header, $content); + $self->method($method); + $self->uri($uri); + $self; +} + + +sub parse +{ + my($class, $str) = @_; + my $request_line; + if ($str =~ s/^(.*)\n//) { + $request_line = $1; + } + else { + $request_line = $str; + $str = ""; + } + + my $self = $class->SUPER::parse($str); + my($method, $uri, $protocol) = split(' ', $request_line); + $self->method($method) if defined($method); + $self->uri($uri) if defined($uri); + $self->protocol($protocol) if $protocol; + $self; +} + + +sub clone +{ + my $self = shift; + my $clone = bless $self->SUPER::clone, ref($self); + $clone->method($self->method); + $clone->uri($self->uri); + $clone; +} + + +sub method +{ + shift->_elem('_method', @_); +} + + +sub uri +{ + my $self = shift; + my $old = $self->{'_uri'}; + if (@_) { + my $uri = shift; + if (!defined $uri) { + # that's ok + } + elsif (ref $uri) { + Carp::croak("A URI can't be a " . ref($uri) . " reference") + if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY'; + Carp::croak("Can't use a " . ref($uri) . " object as a URI") + unless $uri->can('scheme'); + $uri = $uri->clone; + unless ($HTTP::URI_CLASS eq "URI") { + # Argh!! Hate this... old LWP legacy! + eval { local $SIG{__DIE__}; $uri = $uri->abs; }; + die $@ if $@ && $@ !~ /Missing base argument/; + } + } + else { + $uri = $HTTP::URI_CLASS->new($uri); + } + $self->{'_uri'} = $uri; + delete $self->{'_uri_canonical'}; + } + $old; +} + +*url = \&uri; # legacy + +sub uri_canonical +{ + my $self = shift; + return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical; +} + + +sub accept_decodable +{ + my $self = shift; + $self->header("Accept-Encoding", scalar($self->decodable)); +} + +sub as_string +{ + my $self = shift; + my($eol) = @_; + $eol = "\n" unless defined $eol; + + my $req_line = $self->method || "-"; + my $uri = $self->uri; + $uri = (defined $uri) ? $uri->as_string : "-"; + $req_line .= " $uri"; + my $proto = $self->protocol; + $req_line .= " $proto" if $proto; + + return join($eol, $req_line, $self->SUPER::as_string(@_)); +} + +sub dump +{ + my $self = shift; + my @pre = ($self->method || "-", $self->uri || "-"); + if (my $prot = $self->protocol) { + push(@pre, $prot); + } + + return $self->SUPER::dump( + preheader => join(" ", @pre), + @_, + ); +} + + +1; + +__END__ + +=head1 NAME + +HTTP::Request - HTTP style request message + +=head1 SYNOPSIS + + require HTTP::Request; + $request = HTTP::Request->new(GET => 'http://www.example.com/'); + +and usually used like this: + + $ua = LWP::UserAgent->new; + $response = $ua->request($request); + +=head1 DESCRIPTION + +C<HTTP::Request> is a class encapsulating HTTP style requests, +consisting of a request line, some headers, and a content body. Note +that the LWP library uses HTTP style requests even for non-HTTP +protocols. Instances of this class are usually passed to the +request() method of an C<LWP::UserAgent> object. + +C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore +inherits its methods. The following additional methods are available: + +=over 4 + +=item $r = HTTP::Request->new( $method, $uri ) + +=item $r = HTTP::Request->new( $method, $uri, $header ) + +=item $r = HTTP::Request->new( $method, $uri, $header, $content ) + +Constructs a new C<HTTP::Request> object describing a request on the +object $uri using method $method. The $method argument must be a +string. The $uri argument can be either a string, or a reference to a +C<URI> object. The optional $header argument should be a reference to +an C<HTTP::Headers> object or a plain array reference of key/value +pairs. The optional $content argument should be a string of bytes. + +=item $r = HTTP::Request->parse( $str ) + +This constructs a new request object by parsing the given string. + +=item $r->method + +=item $r->method( $val ) + +This is used to get/set the method attribute. The method should be a +short string like "GET", "HEAD", "PUT" or "POST". + +=item $r->uri + +=item $r->uri( $val ) + +This is used to get/set the uri attribute. The $val can be a +reference to a URI object or a plain string. If a string is given, +then it should be parseable as an absolute URI. + +=item $r->header( $field ) + +=item $r->header( $field => $value ) + +This is used to get/set header values and it is inherited from +C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for +details and other similar methods that can be used to access the +headers. + +=item $r->accept_decodable + +This will set the C<Accept-Encoding> header to the list of encodings +that decoded_content() can decode. + +=item $r->content + +=item $r->content( $bytes ) + +This is used to get/set the content and it is inherited from the +C<HTTP::Message> base class. See L<HTTP::Message> for details and +other methods that can be used to access the content. + +Note that the content should be a string of bytes. Strings in perl +can contain characters outside the range of a byte. The C<Encode> +module can be used to turn such strings into a string of bytes. + +=item $r->as_string + +=item $r->as_string( $eol ) + +Method returning a textual representation of the request. + +=back + +=head1 SEE ALSO + +L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>, +L<HTTP::Response> + +=head1 COPYRIGHT + +Copyright 1995-2004 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm b/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm new file mode 100644 index 00000000000..7e3e03a861b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm @@ -0,0 +1,511 @@ +package HTTP::Request::Common; + +use strict; +use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD); + +$DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why) + +require Exporter; +*import = \&Exporter::import; +@EXPORT =qw(GET HEAD PUT POST); +@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE); + +require HTTP::Request; +use Carp(); + +$VERSION = "5.824"; + +my $CRLF = "\015\012"; # "\r\n" is not portable + +sub GET { _simple_req('GET', @_); } +sub HEAD { _simple_req('HEAD', @_); } +sub PUT { _simple_req('PUT' , @_); } +sub DELETE { _simple_req('DELETE', @_); } + +sub POST +{ + my $url = shift; + my $req = HTTP::Request->new(POST => $url); + my $content; + $content = shift if @_ and ref $_[0]; + my($k, $v); + while (($k,$v) = splice(@_, 0, 2)) { + if (lc($k) eq 'content') { + $content = $v; + } + else { + $req->push_header($k, $v); + } + } + my $ct = $req->header('Content-Type'); + unless ($ct) { + $ct = 'application/x-www-form-urlencoded'; + } + elsif ($ct eq 'form-data') { + $ct = 'multipart/form-data'; + } + + if (ref $content) { + if ($ct =~ m,^multipart/form-data\s*(;|$),i) { + require HTTP::Headers::Util; + my @v = HTTP::Headers::Util::split_header_words($ct); + Carp::carp("Multiple Content-Type headers") if @v > 1; + @v = @{$v[0]}; + + my $boundary; + my $boundary_index; + for (my @tmp = @v; @tmp;) { + my($k, $v) = splice(@tmp, 0, 2); + if ($k eq "boundary") { + $boundary = $v; + $boundary_index = @v - @tmp - 1; + last; + } + } + + ($content, $boundary) = form_data($content, $boundary, $req); + + if ($boundary_index) { + $v[$boundary_index] = $boundary; + } + else { + push(@v, boundary => $boundary); + } + + $ct = HTTP::Headers::Util::join_header_words(@v); + } + else { + # We use a temporary URI object to format + # the application/x-www-form-urlencoded content. + require URI; + my $url = URI->new('http:'); + $url->query_form(ref($content) eq "HASH" ? %$content : @$content); + $content = $url->query; + } + } + + $req->header('Content-Type' => $ct); # might be redundant + if (defined($content)) { + $req->header('Content-Length' => + length($content)) unless ref($content); + $req->content($content); + } + else { + $req->header('Content-Length' => 0); + } + $req; +} + + +sub _simple_req +{ + my($method, $url) = splice(@_, 0, 2); + my $req = HTTP::Request->new($method => $url); + my($k, $v); + my $content; + while (($k,$v) = splice(@_, 0, 2)) { + if (lc($k) eq 'content') { + $req->add_content($v); + $content++; + } + else { + $req->push_header($k, $v); + } + } + if ($content && !defined($req->header("Content-Length"))) { + $req->header("Content-Length", length(${$req->content_ref})); + } + $req; +} + + +sub form_data # RFC1867 +{ + my($data, $boundary, $req) = @_; + my @data = ref($data) eq "HASH" ? %$data : @$data; # copy + my $fhparts; + my @parts; + my($k,$v); + while (($k,$v) = splice(@data, 0, 2)) { + if (!ref($v)) { + $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes + push(@parts, + qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v)); + } + else { + my($file, $usename, @headers) = @$v; + unless (defined $usename) { + $usename = $file; + $usename =~ s,.*/,, if defined($usename); + } + $k =~ s/([\\\"])/\\$1/g; + my $disp = qq(form-data; name="$k"); + if (defined($usename) and length($usename)) { + $usename =~ s/([\\\"])/\\$1/g; + $disp .= qq(; filename="$usename"); + } + my $content = ""; + my $h = HTTP::Headers->new(@headers); + if ($file) { + open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!"); + binmode($fh); + if ($DYNAMIC_FILE_UPLOAD) { + # will read file later, close it now in order to + # not accumulate to many open file handles + close($fh); + $content = \$file; + } + else { + local($/) = undef; # slurp files + $content = <$fh>; + close($fh); + } + unless ($h->header("Content-Type")) { + require LWP::MediaTypes; + LWP::MediaTypes::guess_media_type($file, $h); + } + } + if ($h->header("Content-Disposition")) { + # just to get it sorted first + $disp = $h->header("Content-Disposition"); + $h->remove_header("Content-Disposition"); + } + if ($h->header("Content")) { + $content = $h->header("Content"); + $h->remove_header("Content"); + } + my $head = join($CRLF, "Content-Disposition: $disp", + $h->as_string($CRLF), + ""); + if (ref $content) { + push(@parts, [$head, $$content]); + $fhparts++; + } + else { + push(@parts, $head . $content); + } + } + } + return ("", "none") unless @parts; + + my $content; + if ($fhparts) { + $boundary = boundary(10) # hopefully enough randomness + unless $boundary; + + # add the boundaries to the @parts array + for (1..@parts-1) { + splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF"); + } + unshift(@parts, "--$boundary$CRLF"); + push(@parts, "$CRLF--$boundary--$CRLF"); + + # See if we can generate Content-Length header + my $length = 0; + for (@parts) { + if (ref $_) { + my ($head, $f) = @$_; + my $file_size; + unless ( -f $f && ($file_size = -s _) ) { + # The file is either a dynamic file like /dev/audio + # or perhaps a file in the /proc file system where + # stat may return a 0 size even though reading it + # will produce data. So we cannot make + # a Content-Length header. + undef $length; + last; + } + $length += $file_size + length $head; + } + else { + $length += length; + } + } + $length && $req->header('Content-Length' => $length); + + # set up a closure that will return content piecemeal + $content = sub { + for (;;) { + unless (@parts) { + defined $length && $length != 0 && + Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer."; + return; + } + my $p = shift @parts; + unless (ref $p) { + $p .= shift @parts while @parts && !ref($parts[0]); + defined $length && ($length -= length $p); + return $p; + } + my($buf, $fh) = @$p; + unless (ref($fh)) { + my $file = $fh; + undef($fh); + open($fh, "<", $file) || Carp::croak("Can't open file $file: $!"); + binmode($fh); + } + my $buflength = length $buf; + my $n = read($fh, $buf, 2048, $buflength); + if ($n) { + $buflength += $n; + unshift(@parts, ["", $fh]); + } + else { + close($fh); + } + if ($buflength) { + defined $length && ($length -= $buflength); + return $buf + } + } + }; + + } + else { + $boundary = boundary() unless $boundary; + + my $bno = 0; + CHECK_BOUNDARY: + { + for (@parts) { + if (index($_, $boundary) >= 0) { + # must have a better boundary + $boundary = boundary(++$bno); + redo CHECK_BOUNDARY; + } + } + last; + } + $content = "--$boundary$CRLF" . + join("$CRLF--$boundary$CRLF", @parts) . + "$CRLF--$boundary--$CRLF"; + } + + wantarray ? ($content, $boundary) : $content; +} + + +sub boundary +{ + my $size = shift || return "xYzZY"; + require MIME::Base64; + my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); + $b =~ s/[\W]/X/g; # ensure alnum only + $b; +} + +1; + +__END__ + +=head1 NAME + +HTTP::Request::Common - Construct common HTTP::Request objects + +=head1 SYNOPSIS + + use HTTP::Request::Common; + $ua = LWP::UserAgent->new; + $ua->request(GET 'http://www.sn.no/'); + $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]); + +=head1 DESCRIPTION + +This module provide functions that return newly created C<HTTP::Request> +objects. These functions are usually more convenient to use than the +standard C<HTTP::Request> constructor for the most common requests. The +following functions are provided: + +=over 4 + +=item GET $url + +=item GET $url, Header => Value,... + +The GET() function returns an C<HTTP::Request> object initialized with +the "GET" method and the specified URL. It is roughly equivalent to the +following call + + HTTP::Request->new( + GET => $url, + HTTP::Headers->new(Header => Value,...), + ) + +but is less cluttered. What is different is that a header named +C<Content> will initialize the content part of the request instead of +setting a header field. Note that GET requests should normally not +have a content, so this hack makes more sense for the PUT() and POST() +functions described below. + +The get(...) method of C<LWP::UserAgent> exists as a shortcut for +$ua->request(GET ...). + +=item HEAD $url + +=item HEAD $url, Header => Value,... + +Like GET() but the method in the request is "HEAD". + +The head(...) method of "LWP::UserAgent" exists as a shortcut for +$ua->request(HEAD ...). + +=item PUT $url + +=item PUT $url, Header => Value,... + +=item PUT $url, Header => Value,..., Content => $content + +Like GET() but the method in the request is "PUT". + +The content of the request can be specified using the "Content" +pseudo-header. This steals a bit of the header field namespace as +there is no way to directly specify a header that is actually called +"Content". If you really need this you must update the request +returned in a separate statement. + +=item DELETE $url + +=item DELETE $url, Header => Value,... + +Like GET() but the method in the request is "DELETE". This function +is not exported by default. + +=item POST $url + +=item POST $url, Header => Value,... + +=item POST $url, $form_ref, Header => Value,... + +=item POST $url, Header => Value,..., Content => $form_ref + +=item POST $url, Header => Value,..., Content => $content + +This works mostly like PUT() with "POST" as the method, but this +function also takes a second optional array or hash reference +parameter $form_ref. As for PUT() the content can also be specified +directly using the "Content" pseudo-header, and you may also provide +the $form_ref this way. + +The $form_ref argument can be used to pass key/value pairs for the +form content. By default we will initialize a request using the +C<application/x-www-form-urlencoded> content type. This means that +you can emulate a HTML E<lt>form> POSTing like this: + + POST 'http://www.perl.org/survey.cgi', + [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'M', + born => '1964', + perc => '3%', + ]; + +This will create a HTTP::Request object that looks like this: + + POST http://www.perl.org/survey.cgi + Content-Length: 66 + Content-Type: application/x-www-form-urlencoded + + name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25 + +Multivalued form fields can be specified by either repeating the field +name or by passing the value as an array reference. + +The POST method also supports the C<multipart/form-data> content used +for I<Form-based File Upload> as specified in RFC 1867. You trigger +this content format by specifying a content type of C<'form-data'> as +one of the request headers. If one of the values in the $form_ref is +an array reference, then it is treated as a file part specification +with the following interpretation: + + [ $file, $filename, Header => Value... ] + [ undef, $filename, Header => Value,..., Content => $content ] + +The first value in the array ($file) is the name of a file to open. +This file will be read and its content placed in the request. The +routine will croak if the file can't be opened. Use an C<undef> as +$file value if you want to specify the content directly with a +C<Content> header. The $filename is the filename to report in the +request. If this value is undefined, then the basename of the $file +will be used. You can specify an empty string as $filename if you +want to suppress sending the filename when you provide a $file value. + +If a $file is provided by no C<Content-Type> header, then C<Content-Type> +and C<Content-Encoding> will be filled in automatically with the values +returned by LWP::MediaTypes::guess_media_type() + +Sending my F<~/.profile> to the survey used as example above can be +achieved by this: + + POST 'http://www.perl.org/survey.cgi', + Content_Type => 'form-data', + Content => [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'M', + born => '1964', + init => ["$ENV{HOME}/.profile"], + ] + +This will create a HTTP::Request object that almost looks this (the +boundary and the content of your F<~/.profile> is likely to be +different): + + POST http://www.perl.org/survey.cgi + Content-Length: 388 + Content-Type: multipart/form-data; boundary="6G+f" + + --6G+f + Content-Disposition: form-data; name="name" + + Gisle Aas + --6G+f + Content-Disposition: form-data; name="email" + + gisle@aas.no + --6G+f + Content-Disposition: form-data; name="gender" + + M + --6G+f + Content-Disposition: form-data; name="born" + + 1964 + --6G+f + Content-Disposition: form-data; name="init"; filename=".profile" + Content-Type: text/plain + + PATH=/local/perl/bin:$PATH + export PATH + + --6G+f-- + +If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE +value, then you get back a request object with a subroutine closure as +the content attribute. This subroutine will read the content of any +files on demand and return it in suitable chunks. This allow you to +upload arbitrary big files without using lots of memory. You can even +upload infinite files like F</dev/audio> if you wish; however, if +the file is not a plain file, there will be no Content-Length header +defined for the request. Not all servers (or server +applications) like this. Also, if the file(s) change in size between +the time the Content-Length is calculated and the time that the last +chunk is delivered, the subroutine will C<Croak>. + +The post(...) method of "LWP::UserAgent" exists as a shortcut for +$ua->request(POST ...). + +=back + +=head1 SEE ALSO + +L<HTTP::Request>, L<LWP::UserAgent> + + +=head1 COPYRIGHT + +Copyright 1997-2004, 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/HTTP/Response.pm b/Master/tlpkg/tlperl/lib/HTTP/Response.pm new file mode 100644 index 00000000000..b60f06fc09a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Response.pm @@ -0,0 +1,641 @@ +package HTTP::Response; + +require HTTP::Message; +@ISA = qw(HTTP::Message); +$VERSION = "5.836"; + +use strict; +use HTTP::Status (); + + + +sub new +{ + my($class, $rc, $msg, $header, $content) = @_; + my $self = $class->SUPER::new($header, $content); + $self->code($rc); + $self->message($msg); + $self; +} + + +sub parse +{ + my($class, $str) = @_; + my $status_line; + if ($str =~ s/^(.*)\n//) { + $status_line = $1; + } + else { + $status_line = $str; + $str = ""; + } + + my $self = $class->SUPER::parse($str); + my($protocol, $code, $message); + if ($status_line =~ /^\d{3} /) { + # Looks like a response created by HTTP::Response->new + ($code, $message) = split(' ', $status_line, 2); + } else { + ($protocol, $code, $message) = split(' ', $status_line, 3); + } + $self->protocol($protocol) if $protocol; + $self->code($code) if defined($code); + $self->message($message) if defined($message); + $self; +} + + +sub clone +{ + my $self = shift; + my $clone = bless $self->SUPER::clone, ref($self); + $clone->code($self->code); + $clone->message($self->message); + $clone->request($self->request->clone) if $self->request; + # we don't clone previous + $clone; +} + + +sub code { shift->_elem('_rc', @_); } +sub message { shift->_elem('_msg', @_); } +sub previous { shift->_elem('_previous',@_); } +sub request { shift->_elem('_request', @_); } + + +sub status_line +{ + my $self = shift; + my $code = $self->{'_rc'} || "000"; + my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code"; + return "$code $mess"; +} + + +sub base +{ + my $self = shift; + my $base = ( + $self->header('Content-Base'), # used to be HTTP/1.1 + $self->header('Content-Location'), # HTTP/1.1 + $self->header('Base'), # HTTP/1.0 + )[0]; + if ($base && $base =~ /^$URI::scheme_re:/o) { + # already absolute + return $HTTP::URI_CLASS->new($base); + } + + my $req = $self->request; + if ($req) { + # if $base is undef here, the return value is effectively + # just a copy of $self->request->uri. + return $HTTP::URI_CLASS->new_abs($base, $req->uri); + } + + # can't find an absolute base + return undef; +} + + +sub redirects { + my $self = shift; + my @r; + my $r = $self; + while (my $p = $r->previous) { + push(@r, $p); + $r = $p; + } + return @r unless wantarray; + return reverse @r; +} + + +sub filename +{ + my $self = shift; + my $file; + + my $cd = $self->header('Content-Disposition'); + if ($cd) { + require HTTP::Headers::Util; + if (my @cd = HTTP::Headers::Util::split_header_words($cd)) { + my ($disposition, undef, %cd_param) = @{$cd[-1]}; + $file = $cd_param{filename}; + + # RFC 2047 encoded? + if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) { + my $charset = $1; + my $encoding = uc($2); + my $encfile = $3; + + if ($encoding eq 'Q' || $encoding eq 'B') { + local($SIG{__DIE__}); + eval { + if ($encoding eq 'Q') { + $encfile =~ s/_/ /g; + require MIME::QuotedPrint; + $encfile = MIME::QuotedPrint::decode($encfile); + } + else { # $encoding eq 'B' + require MIME::Base64; + $encfile = MIME::Base64::decode($encfile); + } + + require Encode; + require encoding; + # This is ugly use of non-public API, but is there + # a better way to accomplish what we want (locally + # as-is usable filename string)? + my $locale_charset = encoding::_get_locale_encoding(); + Encode::from_to($encfile, $charset, $locale_charset); + }; + + $file = $encfile unless $@; + } + } + } + } + + unless (defined($file) && length($file)) { + my $uri; + if (my $cl = $self->header('Content-Location')) { + $uri = URI->new($cl); + } + elsif (my $request = $self->request) { + $uri = $request->uri; + } + + if ($uri) { + $file = ($uri->path_segments)[-1]; + } + } + + if ($file) { + $file =~ s,.*[\\/],,; # basename + } + + if ($file && !length($file)) { + $file = undef; + } + + $file; +} + + +sub as_string +{ + require HTTP::Status; + my $self = shift; + my($eol) = @_; + $eol = "\n" unless defined $eol; + + my $status_line = $self->status_line; + my $proto = $self->protocol; + $status_line = "$proto $status_line" if $proto; + + return join($eol, $status_line, $self->SUPER::as_string(@_)); +} + + +sub dump +{ + my $self = shift; + + my $status_line = $self->status_line; + my $proto = $self->protocol; + $status_line = "$proto $status_line" if $proto; + + return $self->SUPER::dump( + preheader => $status_line, + @_, + ); +} + + +sub is_info { HTTP::Status::is_info (shift->{'_rc'}); } +sub is_success { HTTP::Status::is_success (shift->{'_rc'}); } +sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); } +sub is_error { HTTP::Status::is_error (shift->{'_rc'}); } + + +sub error_as_HTML +{ + require HTML::Entities; + my $self = shift; + my $title = 'An Error Occurred'; + my $body = HTML::Entities::encode($self->status_line); + return <<EOM; +<html> +<head><title>$title</title></head> +<body> +<h1>$title</h1> +<p>$body</p> +</body> +</html> +EOM +} + + +sub current_age +{ + my $self = shift; + my $time = shift; + + # Implementation of RFC 2616 section 13.2.3 + # (age calculations) + my $response_time = $self->client_date; + my $date = $self->date; + + my $age = 0; + if ($response_time && $date) { + $age = $response_time - $date; # apparent_age + $age = 0 if $age < 0; + } + + my $age_v = $self->header('Age'); + if ($age_v && $age_v > $age) { + $age = $age_v; # corrected_received_age + } + + if ($response_time) { + my $request = $self->request; + if ($request) { + my $request_time = $request->date; + if ($request_time && $request_time < $response_time) { + # Add response_delay to age to get 'corrected_initial_age' + $age += $response_time - $request_time; + } + } + $age += ($time || time) - $response_time; + } + return $age; +} + + +sub freshness_lifetime +{ + my($self, %opt) = @_; + + # First look for the Cache-Control: max-age=n header + for my $cc ($self->header('Cache-Control')) { + for my $cc_dir (split(/\s*,\s*/, $cc)) { + return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i; + } + } + + # Next possibility is to look at the "Expires" header + my $date = $self->date || $self->client_date || $opt{time} || time; + if (my $expires = $self->expires) { + return $expires - $date; + } + + # Must apply heuristic expiration + return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry}; + + # Default heuristic expiration parameters + $opt{h_min} ||= 60; + $opt{h_max} ||= 24 * 3600; + $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616 + $opt{h_default} ||= 3600; + + # Should give a warning if more than 24 hours according to + # RFC 2616 section 13.2.4. Here we just make this the default + # maximum value. + + if (my $last_modified = $self->last_modified) { + my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction}; + return $opt{h_min} if $h_exp < $opt{h_min}; + return $opt{h_max} if $h_exp > $opt{h_max}; + return $h_exp; + } + + # default when all else fails + return $opt{h_min} if $opt{h_min} > $opt{h_default}; + return $opt{h_default}; +} + + +sub is_fresh +{ + my($self, %opt) = @_; + $opt{time} ||= time; + my $f = $self->freshness_lifetime(%opt); + return undef unless defined($f); + return $f > $self->current_age($opt{time}); +} + + +sub fresh_until +{ + my($self, %opt) = @_; + $opt{time} ||= time; + my $f = $self->freshness_lifetime(%opt); + return undef unless defined($f); + return $f - $self->current_age($opt{time}) + $opt{time}; +} + +1; + + +__END__ + +=head1 NAME + +HTTP::Response - HTTP style response message + +=head1 SYNOPSIS + +Response objects are returned by the request() method of the C<LWP::UserAgent>: + + # ... + $response = $ua->request($request) + if ($response->is_success) { + print $response->decoded_content; + } + else { + print STDERR $response->status_line, "\n"; + } + +=head1 DESCRIPTION + +The C<HTTP::Response> class encapsulates HTTP style responses. A +response consists of a response line, some headers, and a content +body. Note that the LWP library uses HTTP style responses even for +non-HTTP protocol schemes. Instances of this class are usually +created and returned by the request() method of an C<LWP::UserAgent> +object. + +C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore +inherits its methods. The following additional methods are available: + +=over 4 + +=item $r = HTTP::Response->new( $code ) + +=item $r = HTTP::Response->new( $code, $msg ) + +=item $r = HTTP::Response->new( $code, $msg, $header ) + +=item $r = HTTP::Response->new( $code, $msg, $header, $content ) + +Constructs a new C<HTTP::Response> object describing a response with +response code $code and optional message $msg. The optional $header +argument should be a reference to an C<HTTP::Headers> object or a +plain array reference of key/value pairs. The optional $content +argument should be a string of bytes. The meaning these arguments are +described below. + +=item $r = HTTP::Response->parse( $str ) + +This constructs a new response object by parsing the given string. + +=item $r->code + +=item $r->code( $code ) + +This is used to get/set the code attribute. The code is a 3 digit +number that encode the overall outcome of a HTTP response. The +C<HTTP::Status> module provide constants that provide mnemonic names +for the code attribute. + +=item $r->message + +=item $r->message( $message ) + +This is used to get/set the message attribute. The message is a short +human readable single line string that explains the response code. + +=item $r->header( $field ) + +=item $r->header( $field => $value ) + +This is used to get/set header values and it is inherited from +C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for +details and other similar methods that can be used to access the +headers. + +=item $r->content + +=item $r->content( $bytes ) + +This is used to get/set the raw content and it is inherited from the +C<HTTP::Message> base class. See L<HTTP::Message> for details and +other methods that can be used to access the content. + +=item $r->decoded_content( %options ) + +This will return the content after any C<Content-Encoding> and +charsets have been decoded. See L<HTTP::Message> for details. + +=item $r->request + +=item $r->request( $request ) + +This is used to get/set the request attribute. The request attribute +is a reference to the the request that caused this response. It does +not have to be the same request passed to the $ua->request() method, +because there might have been redirects and authorization retries in +between. + +=item $r->previous + +=item $r->previous( $response ) + +This is used to get/set the previous attribute. The previous +attribute is used to link together chains of responses. You get +chains of responses if the first response is redirect or unauthorized. +The value is C<undef> if this is the first response in a chain. + +Note that the method $r->redirects is provided as a more convenient +way to access the response chain. + +=item $r->status_line + +Returns the string "E<lt>code> E<lt>message>". If the message attribute +is not set then the official name of E<lt>code> (see L<HTTP::Status>) +is substituted. + +=item $r->base + +Returns the base URI for this response. The return value will be a +reference to a URI object. + +The base URI is obtained from one the following sources (in priority +order): + +=over 4 + +=item 1. + +Embedded in the document content, for instance <BASE HREF="..."> +in HTML documents. + +=item 2. + +A "Content-Base:" or a "Content-Location:" header in the response. + +For backwards compatibility with older HTTP implementations we will +also look for the "Base:" header. + +=item 3. + +The URI used to request this response. This might not be the original +URI that was passed to $ua->request() method, because we might have +received some redirect responses first. + +=back + +If none of these sources provide an absolute URI, undef is returned. + +When the LWP protocol modules produce the HTTP::Response object, then +any base URI embedded in the document (step 1) will already have +initialized the "Content-Base:" header. This means that this method +only performs the last 2 steps (the content is not always available +either). + +=item $r->filename + +Returns a filename for this response. Note that doing sanity checks +on the returned filename (eg. removing characters that cannot be used +on the target filesystem where the filename would be used, and +laundering it for security purposes) are the caller's responsibility; +the only related thing done by this method is that it makes a simple +attempt to return a plain filename with no preceding path segments. + +The filename is obtained from one the following sources (in priority +order): + +=over 4 + +=item 1. + +A "Content-Disposition:" header in the response. Proper decoding of +RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q" +encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules. + +=item 2. + +A "Content-Location:" header in the response. + +=item 3. + +The URI used to request this response. This might not be the original +URI that was passed to $ua->request() method, because we might have +received some redirect responses first. + +=back + +If a filename cannot be derived from any of these sources, undef is +returned. + +=item $r->as_string + +=item $r->as_string( $eol ) + +Returns a textual representation of the response. + +=item $r->is_info + +=item $r->is_success + +=item $r->is_redirect + +=item $r->is_error + +These methods indicate if the response was informational, successful, a +redirection, or an error. See L<HTTP::Status> for the meaning of these. + +=item $r->error_as_HTML + +Returns a string containing a complete HTML document indicating what +error occurred. This method should only be called when $r->is_error +is TRUE. + +=item $r->redirects + +Returns the list of redirect responses that lead up to this response +by following the $r->previous chain. The list order is oldest first. + +In scalar context return the number of redirect responses leading up +to this one. + +=item $r->current_age + +Calculates the "current age" of the response as specified by RFC 2616 +section 13.2.3. The age of a response is the time since it was sent +by the origin server. The returned value is a number representing the +age in seconds. + +=item $r->freshness_lifetime( %opt ) + +Calculates the "freshness lifetime" of the response as specified by +RFC 2616 section 13.2.4. The "freshness lifetime" is the length of +time between the generation of a response and its expiration time. +The returned value is the number of seconds until expiry. + +If the response does not contain an "Expires" or a "Cache-Control" +header, then this function will apply some simple heuristic based on +the "Last-Modified" header to determine a suitable lifetime. The +following options might be passed to control the heuristics: + +=over + +=item heuristic_expiry => $bool + +If passed as a FALSE value, don't apply heuristics and just return +C<undef> when "Expires" or "Cache-Control" is lacking. + +=item h_lastmod_fraction => $num + +This number represent the fraction of the difference since the +"Last-Modified" timestamp to make the expiry time. The default is +C<0.10>, the suggested typical setting of 10% in RFC 2616. + +=item h_min => $sec + +This is the lower limit of the heuristic expiry age to use. The +default is C<60> (1 minute). + +=item h_max => $sec + +This is the upper limit of the heuristic expiry age to use. The +default is C<86400> (24 hours). + +=item h_default => $sec + +This is the expiry age to use when nothing else applies. The default +is C<3600> (1 hour) or "h_min" if greater. + +=back + +=item $r->is_fresh( %opt ) + +Returns TRUE if the response is fresh, based on the values of +freshness_lifetime() and current_age(). If the response is no longer +fresh, then it has to be re-fetched or re-validated by the origin +server. + +Options might be passed to control expiry heuristics, see the +description of freshness_lifetime(). + +=item $r->fresh_until( %opt ) + +Returns the time (seconds since epoch) when this entity is no longer fresh. + +Options might be passed to control expiry heuristics, see the +description of freshness_lifetime(). + +=back + +=head1 SEE ALSO + +L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request> + +=head1 COPYRIGHT + +Copyright 1995-2004 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/HTTP/Status.pm b/Master/tlpkg/tlperl/lib/HTTP/Status.pm new file mode 100644 index 00000000000..930bd878858 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/HTTP/Status.pm @@ -0,0 +1,254 @@ +package HTTP::Status; + +use strict; +require 5.002; # because we use prototypes + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(is_info is_success is_redirect is_error status_message); +@EXPORT_OK = qw(is_client_error is_server_error); +$VERSION = "5.817"; + +# Note also addition of mnemonics to @EXPORT below + +# Unmarked codes are from RFC 2616 +# See also: http://en.wikipedia.org/wiki/List_of_HTTP_status_codes + +my %StatusCode = ( + 100 => 'Continue', + 101 => 'Switching Protocols', + 102 => 'Processing', # RFC 2518 (WebDAV) + 200 => 'OK', + 201 => 'Created', + 202 => 'Accepted', + 203 => 'Non-Authoritative Information', + 204 => 'No Content', + 205 => 'Reset Content', + 206 => 'Partial Content', + 207 => 'Multi-Status', # RFC 2518 (WebDAV) + 300 => 'Multiple Choices', + 301 => 'Moved Permanently', + 302 => 'Found', + 303 => 'See Other', + 304 => 'Not Modified', + 305 => 'Use Proxy', + 307 => 'Temporary Redirect', + 400 => 'Bad Request', + 401 => 'Unauthorized', + 402 => 'Payment Required', + 403 => 'Forbidden', + 404 => 'Not Found', + 405 => 'Method Not Allowed', + 406 => 'Not Acceptable', + 407 => 'Proxy Authentication Required', + 408 => 'Request Timeout', + 409 => 'Conflict', + 410 => 'Gone', + 411 => 'Length Required', + 412 => 'Precondition Failed', + 413 => 'Request Entity Too Large', + 414 => 'Request-URI Too Large', + 415 => 'Unsupported Media Type', + 416 => 'Request Range Not Satisfiable', + 417 => 'Expectation Failed', + 422 => 'Unprocessable Entity', # RFC 2518 (WebDAV) + 423 => 'Locked', # RFC 2518 (WebDAV) + 424 => 'Failed Dependency', # RFC 2518 (WebDAV) + 425 => 'No code', # WebDAV Advanced Collections + 426 => 'Upgrade Required', # RFC 2817 + 449 => 'Retry with', # unofficial Microsoft + 500 => 'Internal Server Error', + 501 => 'Not Implemented', + 502 => 'Bad Gateway', + 503 => 'Service Unavailable', + 504 => 'Gateway Timeout', + 505 => 'HTTP Version Not Supported', + 506 => 'Variant Also Negotiates', # RFC 2295 + 507 => 'Insufficient Storage', # RFC 2518 (WebDAV) + 509 => 'Bandwidth Limit Exceeded', # unofficial + 510 => 'Not Extended', # RFC 2774 +); + +my $mnemonicCode = ''; +my ($code, $message); +while (($code, $message) = each %StatusCode) { + # create mnemonic subroutines + $message =~ tr/a-z \-/A-Z__/; + $mnemonicCode .= "sub HTTP_$message () { $code }\n"; + $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy + $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n"; + $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n"; +} +eval $mnemonicCode; # only one eval for speed +die if $@; + +# backwards compatibility +*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard +push(@EXPORT, "RC_MOVED_TEMPORARILY"); + +%EXPORT_TAGS = ( + constants => [grep /^HTTP_/, @EXPORT_OK], + is => [grep /^is_/, @EXPORT, @EXPORT_OK], +); + + +sub status_message ($) { $StatusCode{$_[0]}; } + +sub is_info ($) { $_[0] >= 100 && $_[0] < 200; } +sub is_success ($) { $_[0] >= 200 && $_[0] < 300; } +sub is_redirect ($) { $_[0] >= 300 && $_[0] < 400; } +sub is_error ($) { $_[0] >= 400 && $_[0] < 600; } +sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; } +sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; } + +1; + + +__END__ + +=head1 NAME + +HTTP::Status - HTTP Status code processing + +=head1 SYNOPSIS + + use HTTP::Status qw(:constants :is status_message); + + if ($rc != HTTP_OK) { + print status_message($rc), "\n"; + } + + if (is_success($rc)) { ... } + if (is_error($rc)) { ... } + if (is_redirect($rc)) { ... } + +=head1 DESCRIPTION + +I<HTTP::Status> is a library of routines for defining and +classifying HTTP status codes for libwww-perl. Status codes are +used to encode the overall outcome of a HTTP response message. Codes +correspond to those defined in RFC 2616 and RFC 2518. + +=head1 CONSTANTS + +The following constant functions can be used as mnemonic status code +names. None of these are exported by default. Use the C<:constants> +tag to import them all. + + HTTP_CONTINUE (100) + HTTP_SWITCHING_PROTOCOLS (101) + HTTP_PROCESSING (102) + + HTTP_OK (200) + HTTP_CREATED (201) + HTTP_ACCEPTED (202) + HTTP_NON_AUTHORITATIVE_INFORMATION (203) + HTTP_NO_CONTENT (204) + HTTP_RESET_CONTENT (205) + HTTP_PARTIAL_CONTENT (206) + HTTP_MULTI_STATUS (207) + + HTTP_MULTIPLE_CHOICES (300) + HTTP_MOVED_PERMANENTLY (301) + HTTP_FOUND (302) + HTTP_SEE_OTHER (303) + HTTP_NOT_MODIFIED (304) + HTTP_USE_PROXY (305) + HTTP_TEMPORARY_REDIRECT (307) + + HTTP_BAD_REQUEST (400) + HTTP_UNAUTHORIZED (401) + HTTP_PAYMENT_REQUIRED (402) + HTTP_FORBIDDEN (403) + HTTP_NOT_FOUND (404) + HTTP_METHOD_NOT_ALLOWED (405) + HTTP_NOT_ACCEPTABLE (406) + HTTP_PROXY_AUTHENTICATION_REQUIRED (407) + HTTP_REQUEST_TIMEOUT (408) + HTTP_CONFLICT (409) + HTTP_GONE (410) + HTTP_LENGTH_REQUIRED (411) + HTTP_PRECONDITION_FAILED (412) + HTTP_REQUEST_ENTITY_TOO_LARGE (413) + HTTP_REQUEST_URI_TOO_LARGE (414) + HTTP_UNSUPPORTED_MEDIA_TYPE (415) + HTTP_REQUEST_RANGE_NOT_SATISFIABLE (416) + HTTP_EXPECTATION_FAILED (417) + HTTP_UNPROCESSABLE_ENTITY (422) + HTTP_LOCKED (423) + HTTP_FAILED_DEPENDENCY (424) + HTTP_NO_CODE (425) + HTTP_UPGRADE_REQUIRED (426) + HTTP_RETRY_WITH (449) + + HTTP_INTERNAL_SERVER_ERROR (500) + HTTP_NOT_IMPLEMENTED (501) + HTTP_BAD_GATEWAY (502) + HTTP_SERVICE_UNAVAILABLE (503) + HTTP_GATEWAY_TIMEOUT (504) + HTTP_HTTP_VERSION_NOT_SUPPORTED (505) + HTTP_VARIANT_ALSO_NEGOTIATES (506) + HTTP_INSUFFICIENT_STORAGE (507) + HTTP_BANDWIDTH_LIMIT_EXCEEDED (509) + HTTP_NOT_EXTENDED (510) + +=head1 FUNCTIONS + +The following additional functions are provided. Most of them are +exported by default. The C<:is> import tag can be used to import all +the classification functions. + +=over 4 + +=item status_message( $code ) + +The status_message() function will translate status codes to human +readable strings. The string is the same as found in the constant +names above. If the $code is unknown, then C<undef> is returned. + +=item is_info( $code ) + +Return TRUE if C<$code> is an I<Informational> status code (1xx). This +class of status code indicates a provisional response which can't have +any content. + +=item is_success( $code ) + +Return TRUE if C<$code> is a I<Successful> status code (2xx). + +=item is_redirect( $code ) + +Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of +status code indicates that further action needs to be taken by the +user agent in order to fulfill the request. + +=item is_error( $code ) + +Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function +return TRUE for both client error or a server error status codes. + +=item is_client_error( $code ) + +Return TRUE if C<$code> is an I<Client Error> status code (4xx). This class +of status code is intended for cases in which the client seems to have +erred. + +This function is B<not> exported by default. + +=item is_server_error( $code ) + +Return TRUE if C<$code> is an I<Server Error> status code (5xx). This class +of status codes is intended for cases in which the server is aware +that it has erred or is incapable of performing the request. + +This function is B<not> exported by default. + +=back + +=head1 BUGS + +For legacy reasons all the C<HTTP_> constants are exported by default +with the prefix C<RC_>. It's recommended to use explict imports and +the C<:constants> tag instead of relying on this. diff --git a/Master/tlpkg/tlperl/lib/LWP.pm b/Master/tlpkg/tlperl/lib/LWP.pm new file mode 100644 index 00000000000..5ca47855701 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP.pm @@ -0,0 +1,654 @@ +package LWP; + +$VERSION = "5.837"; +sub Version { $VERSION; } + +require 5.005; +require LWP::UserAgent; # this should load everything you need + +1; + +__END__ + +=head1 NAME + +LWP - The World-Wide Web library for Perl + +=head1 SYNOPSIS + + use LWP; + print "This is libwww-perl-$LWP::VERSION\n"; + + +=head1 DESCRIPTION + +The libwww-perl collection is a set of Perl modules which provides a +simple and consistent application programming interface (API) to the +World-Wide Web. The main focus of the library is to provide classes +and functions that allow you to write WWW clients. The library also +contain modules that are of more general use and even classes that +help you implement simple HTTP servers. + +Most modules in this library provide an object oriented API. The user +agent, requests sent and responses received from the WWW server are +all represented by objects. This makes a simple and powerful +interface to these services. The interface is easy to extend +and customize for your own needs. + +The main features of the library are: + +=over 3 + +=item * + +Contains various reusable components (modules) that can be +used separately or together. + +=item * + +Provides an object oriented model of HTTP-style communication. Within +this framework we currently support access to http, https, gopher, ftp, news, +file, and mailto resources. + +=item * + +Provides a full object oriented interface or +a very simple procedural interface. + +=item * + +Supports the basic and digest authorization schemes. + +=item * + +Supports transparent redirect handling. + +=item * + +Supports access through proxy servers. + +=item * + +Provides parser for F<robots.txt> files and a framework for constructing robots. + +=item * + +Supports parsing of HTML forms. + +=item * + +Implements HTTP content negotiation algorithm that can +be used both in protocol modules and in server scripts (like CGI +scripts). + +=item * + +Supports HTTP cookies. + +=item * + +Some simple command line clients, for instance C<lwp-request> and C<lwp-download>. + +=back + + +=head1 HTTP STYLE COMMUNICATION + + +The libwww-perl library is based on HTTP style communication. This +section tries to describe what that means. + +Let us start with this quote from the HTTP specification document +<URL:http://www.w3.org/pub/WWW/Protocols/>: + +=over 3 + +=item + +The HTTP protocol is based on a request/response paradigm. A client +establishes a connection with a server and sends a request to the +server in the form of a request method, URI, and protocol version, +followed by a MIME-like message containing request modifiers, client +information, and possible body content. The server responds with a +status line, including the message's protocol version and a success or +error code, followed by a MIME-like message containing server +information, entity meta-information, and possible body content. + +=back + +What this means to libwww-perl is that communication always take place +through these steps: First a I<request> object is created and +configured. This object is then passed to a server and we get a +I<response> object in return that we can examine. A request is always +independent of any previous requests, i.e. the service is stateless. +The same simple model is used for any kind of service we want to +access. + +For example, if we want to fetch a document from a remote file server, +then we send it a request that contains a name for that document and +the response will contain the document itself. If we access a search +engine, then the content of the request will contain the query +parameters and the response will contain the query result. If we want +to send a mail message to somebody then we send a request object which +contains our message to the mail server and the response object will +contain an acknowledgment that tells us that the message has been +accepted and will be forwarded to the recipient(s). + +It is as simple as that! + + +=head2 The Request Object + +The libwww-perl request object has the class name C<HTTP::Request>. +The fact that the class name uses C<HTTP::> as a +prefix only implies that we use the HTTP model of communication. It +does not limit the kind of services we can try to pass this I<request> +to. For instance, we will send C<HTTP::Request>s both to ftp and +gopher servers, as well as to the local file system. + +The main attributes of the request objects are: + +=over 3 + +=item * + +The B<method> is a short string that tells what kind of +request this is. The most common methods are B<GET>, B<PUT>, +B<POST> and B<HEAD>. + +=item * + +The B<uri> is a string denoting the protocol, server and +the name of the "document" we want to access. The B<uri> might +also encode various other parameters. + +=item * + +The B<headers> contain additional information about the +request and can also used to describe the content. The headers +are a set of keyword/value pairs. + +=item * + +The B<content> is an arbitrary amount of data. + +=back + +=head2 The Response Object + +The libwww-perl response object has the class name C<HTTP::Response>. +The main attributes of objects of this class are: + +=over 3 + +=item * + +The B<code> is a numerical value that indicates the overall +outcome of the request. + +=item * + +The B<message> is a short, human readable string that +corresponds to the I<code>. + +=item * + +The B<headers> contain additional information about the +response and describe the content. + +=item * + +The B<content> is an arbitrary amount of data. + +=back + +Since we don't want to handle all possible I<code> values directly in +our programs, a libwww-perl response object has methods that can be +used to query what kind of response this is. The most commonly used +response classification methods are: + +=over 3 + +=item is_success() + +The request was was successfully received, understood or accepted. + +=item is_error() + +The request failed. The server or the resource might not be +available, access to the resource might be denied or other things might +have failed for some reason. + +=back + +=head2 The User Agent + +Let us assume that we have created a I<request> object. What do we +actually do with it in order to receive a I<response>? + +The answer is that you pass it to a I<user agent> object and this +object takes care of all the things that need to be done +(like low-level communication and error handling) and returns +a I<response> object. The user agent represents your +application on the network and provides you with an interface that +can accept I<requests> and return I<responses>. + +The user agent is an interface layer between +your application code and the network. Through this interface you are +able to access the various servers on the network. + +The class name for the user agent is C<LWP::UserAgent>. Every +libwww-perl application that wants to communicate should create at +least one object of this class. The main method provided by this +object is request(). This method takes an C<HTTP::Request> object as +argument and (eventually) returns a C<HTTP::Response> object. + +The user agent has many other attributes that let you +configure how it will interact with the network and with your +application. + +=over 3 + +=item * + +The B<timeout> specifies how much time we give remote servers to +respond before the library disconnects and creates an +internal I<timeout> response. + +=item * + +The B<agent> specifies the name that your application should use when it +presents itself on the network. + +=item * + +The B<from> attribute can be set to the e-mail address of the person +responsible for running the application. If this is set, then the +address will be sent to the servers with every request. + +=item * + +The B<parse_head> specifies whether we should initialize response +headers from the E<lt>head> section of HTML documents. + +=item * + +The B<proxy> and B<no_proxy> attributes specify if and when to go through +a proxy server. <URL:http://www.w3.org/pub/WWW/Proxies/> + +=item * + +The B<credentials> provide a way to set up user names and +passwords needed to access certain services. + +=back + +Many applications want even more control over how they interact +with the network and they get this by sub-classing +C<LWP::UserAgent>. The library includes a +sub-class, C<LWP::RobotUA>, for robot applications. + +=head2 An Example + +This example shows how the user agent, a request and a response are +represented in actual perl code: + + # Create a user agent object + use LWP::UserAgent; + my $ua = LWP::UserAgent->new; + $ua->agent("MyApp/0.1 "); + + # Create a request + my $req = HTTP::Request->new(POST => 'http://search.cpan.org/search'); + $req->content_type('application/x-www-form-urlencoded'); + $req->content('query=libwww-perl&mode=dist'); + + # Pass request to the user agent and get a response back + my $res = $ua->request($req); + + # Check the outcome of the response + if ($res->is_success) { + print $res->content; + } + else { + print $res->status_line, "\n"; + } + +The $ua is created once when the application starts up. New request +objects should normally created for each request sent. + + +=head1 NETWORK SUPPORT + +This section discusses the various protocol schemes and +the HTTP style methods that headers may be used for each. + +For all requests, a "User-Agent" header is added and initialized from +the $ua->agent attribute before the request is handed to the network +layer. In the same way, a "From" header is initialized from the +$ua->from attribute. + +For all responses, the library adds a header called "Client-Date". +This header holds the time when the response was received by +your application. The format and semantics of the header are the +same as the server created "Date" header. You may also encounter other +"Client-XXX" headers. They are all generated by the library +internally and are not received from the servers. + +=head2 HTTP Requests + +HTTP requests are just handed off to an HTTP server and it +decides what happens. Few servers implement methods beside the usual +"GET", "HEAD", "POST" and "PUT", but CGI-scripts may implement +any method they like. + +If the server is not available then the library will generate an +internal error response. + +The library automatically adds a "Host" and a "Content-Length" header +to the HTTP request before it is sent over the network. + +For a GET request you might want to add a "If-Modified-Since" or +"If-None-Match" header to make the request conditional. + +For a POST request you should add the "Content-Type" header. When you +try to emulate HTML E<lt>FORM> handling you should usually let the value +of the "Content-Type" header be "application/x-www-form-urlencoded". +See L<lwpcook> for examples of this. + +The libwww-perl HTTP implementation currently support the HTTP/1.1 +and HTTP/1.0 protocol. + +The library allows you to access proxy server through HTTP. This +means that you can set up the library to forward all types of request +through the HTTP protocol module. See L<LWP::UserAgent> for +documentation of this. + + +=head2 HTTPS Requests + +HTTPS requests are HTTP requests over an encrypted network connection +using the SSL protocol developed by Netscape. Everything about HTTP +requests above also apply to HTTPS requests. In addition the library +will add the headers "Client-SSL-Cipher", "Client-SSL-Cert-Subject" and +"Client-SSL-Cert-Issuer" to the response. These headers denote the +encryption method used and the name of the server owner. + +The request can contain the header "If-SSL-Cert-Subject" in order to +make the request conditional on the content of the server certificate. +If the certificate subject does not match, no request is sent to the +server and an internally generated error response is returned. The +value of the "If-SSL-Cert-Subject" header is interpreted as a Perl +regular expression. + + +=head2 FTP Requests + +The library currently supports GET, HEAD and PUT requests. GET +retrieves a file or a directory listing from an FTP server. PUT +stores a file on a ftp server. + +You can specify a ftp account for servers that want this in addition +to user name and password. This is specified by including an "Account" +header in the request. + +User name/password can be specified using basic authorization or be +encoded in the URL. Failed logins return an UNAUTHORIZED response with +"WWW-Authenticate: Basic" and can be treated like basic authorization +for HTTP. + +The library supports ftp ASCII transfer mode by specifying the "type=a" +parameter in the URL. It also supports transfer of ranges for FTP transfers +using the "Range" header. + +Directory listings are by default returned unprocessed (as returned +from the ftp server) with the content media type reported to be +"text/ftp-dir-listing". The C<File::Listing> module provides methods +for parsing of these directory listing. + +The ftp module is also able to convert directory listings to HTML and +this can be requested via the standard HTTP content negotiation +mechanisms (add an "Accept: text/html" header in the request if you +want this). + +For normal file retrievals, the "Content-Type" is guessed based on the +file name suffix. See L<LWP::MediaTypes>. + +The "If-Modified-Since" request header works for servers that implement +the MDTM command. It will probably not work for directory listings though. + +Example: + + $req = HTTP::Request->new(GET => 'ftp://me:passwd@ftp.some.where.com/'); + $req->header(Accept => "text/html, */*;q=0.1"); + +=head2 News Requests + +Access to the USENET News system is implemented through the NNTP +protocol. The name of the news server is obtained from the +NNTP_SERVER environment variable and defaults to "news". It is not +possible to specify the hostname of the NNTP server in news: URLs. + +The library supports GET and HEAD to retrieve news articles through the +NNTP protocol. You can also post articles to newsgroups by using +(surprise!) the POST method. + +GET on newsgroups is not implemented yet. + +Examples: + + $req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no'); + + $req = HTTP::Request->new(POST => 'news:comp.lang.perl.test'); + $req->header(Subject => 'This is a test', + From => 'me@some.where.org'); + $req->content(<<EOT); + This is the content of the message that we are sending to + the world. + EOT + + +=head2 Gopher Request + +The library supports the GET and HEAD methods for gopher requests. All +request header values are ignored. HEAD cheats and returns a +response without even talking to server. + +Gopher menus are always converted to HTML. + +The response "Content-Type" is generated from the document type +encoded (as the first letter) in the request URL path itself. + +Example: + + $req = HTTP::Request->new(GET => 'gopher://gopher.sn.no/'); + + + +=head2 File Request + +The library supports GET and HEAD methods for file requests. The +"If-Modified-Since" header is supported. All other headers are +ignored. The I<host> component of the file URL must be empty or set +to "localhost". Any other I<host> value will be treated as an error. + +Directories are always converted to an HTML document. For normal +files, the "Content-Type" and "Content-Encoding" in the response are +guessed based on the file suffix. + +Example: + + $req = HTTP::Request->new(GET => 'file:/etc/passwd'); + + +=head2 Mailto Request + +You can send (aka "POST") mail messages using the library. All +headers specified for the request are passed on to the mail system. +The "To" header is initialized from the mail address in the URL. + +Example: + + $req = HTTP::Request->new(POST => 'mailto:libwww@perl.org'); + $req->header(Subject => "subscribe"); + $req->content("Please subscribe me to the libwww-perl mailing list!\n"); + +=head2 CPAN Requests + +URLs with scheme C<cpan:> are redirected to the a suitable CPAN +mirror. If you have your own local mirror of CPAN you might tell LWP +to use it for C<cpan:> URLs by an assignment like this: + + $LWP::Protocol::cpan::CPAN = "file:/local/CPAN/"; + +Suitable CPAN mirrors are also picked up from the configuration for +the CPAN.pm, so if you have used that module a suitable mirror should +be picked automatically. If neither of these apply, then a redirect +to the generic CPAN http location is issued. + +Example request to download the newest perl: + + $req = HTTP::Request->new(GET => "cpan:src/latest.tar.gz"); + + +=head1 OVERVIEW OF CLASSES AND PACKAGES + +This table should give you a quick overview of the classes provided by the +library. Indentation shows class inheritance. + + LWP::MemberMixin -- Access to member variables of Perl5 classes + LWP::UserAgent -- WWW user agent class + LWP::RobotUA -- When developing a robot applications + LWP::Protocol -- Interface to various protocol schemes + LWP::Protocol::http -- http:// access + LWP::Protocol::file -- file:// access + LWP::Protocol::ftp -- ftp:// access + ... + + LWP::Authen::Basic -- Handle 401 and 407 responses + LWP::Authen::Digest + + HTTP::Headers -- MIME/RFC822 style header (used by HTTP::Message) + HTTP::Message -- HTTP style message + HTTP::Request -- HTTP request + HTTP::Response -- HTTP response + HTTP::Daemon -- A HTTP server class + + WWW::RobotRules -- Parse robots.txt files + WWW::RobotRules::AnyDBM_File -- Persistent RobotRules + + Net::HTTP -- Low level HTTP client + +The following modules provide various functions and definitions. + + LWP -- This file. Library version number and documentation. + LWP::MediaTypes -- MIME types configuration (text/html etc.) + LWP::Simple -- Simplified procedural interface for common functions + HTTP::Status -- HTTP status code (200 OK etc) + HTTP::Date -- Date parsing module for HTTP date formats + HTTP::Negotiate -- HTTP content negotiation calculation + File::Listing -- Parse directory listings + HTML::Form -- Processing for <form>s in HTML documents + + +=head1 MORE DOCUMENTATION + +All modules contain detailed information on the interfaces they +provide. The L<lwpcook> manpage is the libwww-perl cookbook that contain +examples of typical usage of the library. You might want to take a +look at how the scripts L<lwp-request>, L<lwp-rget> and L<lwp-mirror> +are implemented. + +=head1 ENVIRONMENT + +The following environment variables are used by LWP: + +=over + +=item HOME + +The C<LWP::MediaTypes> functions will look for the F<.media.types> and +F<.mime.types> files relative to you home directory. + +=item http_proxy + +=item ftp_proxy + +=item xxx_proxy + +=item no_proxy + +These environment variables can be set to enable communication through +a proxy server. See the description of the C<env_proxy> method in +L<LWP::UserAgent>. + +=item PERL_LWP_USE_HTTP_10 + +Enable the old HTTP/1.0 protocol driver instead of the new HTTP/1.1 +driver. You might want to set this to a TRUE value if you discover +that your old LWP applications fails after you installed LWP-5.60 or +better. + +=item PERL_HTTP_URI_CLASS + +Used to decide what URI objects to instantiate. The default is C<URI>. +You might want to set it to C<URI::URL> for compatibility with old times. + +=back + +=head1 AUTHORS + +LWP was made possible by contributions from Adam Newby, Albert +Dvornik, Alexandre Duret-Lutz, Andreas Gustafsson, Andreas König, +Andrew Pimlott, Andy Lester, Ben Coleman, Benjamin Low, Ben Low, Ben +Tilly, Blair Zajac, Bob Dalgleish, BooK, Brad Hughes, Brian +J. Murrell, Brian McCauley, Charles C. Fu, Charles Lane, Chris Nandor, +Christian Gilmore, Chris W. Unger, Craig Macdonald, Dale Couch, Dan +Kubb, Dave Dunkin, Dave W. Smith, David Coppit, David Dick, David +D. Kilzer, Doug MacEachern, Edward Avis, erik, Gary Shea, Gisle Aas, +Graham Barr, Gurusamy Sarathy, Hans de Graaff, Harald Joerg, Harry +Bochner, Hugo, Ilya Zakharevich, INOUE Yoshinari, Ivan Panchenko, Jack +Shirazi, James Tillman, Jan Dubois, Jared Rhine, Jim Stern, Joao +Lopes, John Klar, Johnny Lee, Josh Kronengold, Josh Rai, Joshua +Chamas, Joshua Hoblitt, Kartik Subbarao, Keiichiro Nagano, Ken +Williams, KONISHI Katsuhiro, Lee T Lindley, Liam Quinn, Marc Hedlund, +Marc Langheinrich, Mark D. Anderson, Marko Asplund, Mark Stosberg, +Markus B Krüger, Markus Laker, Martijn Koster, Martin Thurn, Matthew +Eldridge, Matthew.van.Eerde, Matt Sergeant, Michael A. Chase, Michael +Quaranta, Michael Thompson, Mike Schilli, Moshe Kaminsky, Nathan +Torkington, Nicolai Langfeldt, Norton Allen, Olly Betts, Paul +J. Schinder, peterm, Philip GuentherDaniel Buenzli, Pon Hwa Lin, +Radoslaw Zielinski, Radu Greab, Randal L. Schwartz, Richard Chen, +Robin Barker, Roy Fielding, Sander van Zoest, Sean M. Burke, +shildreth, Slaven Rezic, Steve A Fink, Steve Hay, Steven Butler, +Steve_Kilbane, Takanori Ugai, Thomas Lotterer, Tim Bunce, Tom Hughes, +Tony Finch, Ville Skyttä, Ward Vandewege, William York, Yale Huang, +and Yitzchak Scott-Thoennes. + +LWP owes a lot in motivation, design, and code, to the libwww-perl +library for Perl4 by Roy Fielding, which included work from Alberto +Accomazzi, James Casey, Brooks Cutter, Martijn Koster, Oscar +Nierstrasz, Mel Melchner, Gertjan van Oosten, Jared Rhine, Jack +Shirazi, Gene Spafford, Marc VanHeyningen, Steven E. Brenner, Marion +Hakanson, Waldemar Kebsch, Tony Sanders, and Larry Wall; see the +libwww-perl-0.40 library for details. + +=head1 COPYRIGHT + + Copyright 1995-2009, Gisle Aas + Copyright 1995, Martijn Koster + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 AVAILABILITY + +The latest version of this library is likely to be available from CPAN +as well as: + + http://github.com/gisle/libwww-perl + +The best place to discuss this code is on the <libwww@perl.org> +mailing list. + +=cut diff --git a/Master/tlpkg/tlperl/lib/LWP/Authen/Basic.pm b/Master/tlpkg/tlperl/lib/LWP/Authen/Basic.pm new file mode 100644 index 00000000000..e7815bd247f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Authen/Basic.pm @@ -0,0 +1,65 @@ +package LWP::Authen::Basic; +use strict; + +require MIME::Base64; + +sub auth_header { + my($class, $user, $pass) = @_; + return "Basic " . MIME::Base64::encode("$user:$pass", ""); +} + +sub authenticate +{ + my($class, $ua, $proxy, $auth_param, $response, + $request, $arg, $size) = @_; + + my $realm = $auth_param->{realm} || ""; + my $url = $proxy ? $request->{proxy} : $request->uri_canonical; + return $response unless $url; + my $host_port = $url->host_port; + my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization"; + + my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port); + push(@m, realm => $realm); + + my $h = $ua->get_my_handler("request_prepare", @m, sub { + $_[0]{callback} = sub { + my($req, $ua, $h) = @_; + my($user, $pass) = $ua->credentials($host_port, $h->{realm}); + if (defined $user) { + my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h); + $req->header($auth_header => $auth_value); + } + }; + }); + $h->{auth_param} = $auth_param; + + if (!$proxy && !$request->header($auth_header) && $ua->credentials($host_port, $realm)) { + # we can make sure this handler applies and retry + add_path($h, $url->path); + return $ua->request($request->clone, $arg, $size, $response); + } + + my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy); + unless (defined $user and defined $pass) { + $ua->set_my_handler("request_prepare", undef, @m); # delete handler + return $response; + } + + # check that the password has changed + my ($olduser, $oldpass) = $ua->credentials($host_port, $realm); + return $response if (defined $olduser and defined $oldpass and + $user eq $olduser and $pass eq $oldpass); + + $ua->credentials($host_port, $realm, $user, $pass); + add_path($h, $url->path) unless $proxy; + return $ua->request($request->clone, $arg, $size, $response); +} + +sub add_path { + my($h, $path) = @_; + $path =~ s,[^/]+\z,,; + push(@{$h->{m_path_prefix}}, $path); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Authen/Digest.pm b/Master/tlpkg/tlperl/lib/LWP/Authen/Digest.pm new file mode 100644 index 00000000000..b9365ae1c12 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Authen/Digest.pm @@ -0,0 +1,68 @@ +package LWP::Authen::Digest; + +use strict; +use base 'LWP::Authen::Basic'; + +require Digest::MD5; + +sub auth_header { + my($class, $user, $pass, $request, $ua, $h) = @_; + + my $auth_param = $h->{auth_param}; + + my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}}; + my $cnonce = sprintf "%8x", time; + + my $uri = $request->uri->path_query; + $uri = "/" unless length $uri; + + my $md5 = Digest::MD5->new; + + my(@digest); + $md5->add(join(":", $user, $auth_param->{realm}, $pass)); + push(@digest, $md5->hexdigest); + $md5->reset; + + push(@digest, $auth_param->{nonce}); + + if ($auth_param->{qop}) { + push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop}); + } + + $md5->add(join(":", $request->method, $uri)); + push(@digest, $md5->hexdigest); + $md5->reset; + + $md5->add(join(":", @digest)); + my($digest) = $md5->hexdigest; + $md5->reset; + + my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque); + @resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5"); + + if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) { + @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc); + } + + my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response); + if($request->method =~ /^(?:POST|PUT)$/) { + $md5->add($request->content); + my $content = $md5->hexdigest; + $md5->reset; + $md5->add(join(":", @digest[0..1], $content)); + $md5->reset; + $resp{"message-digest"} = $md5->hexdigest; + push(@order, "message-digest"); + } + push(@order, "opaque"); + my @pairs; + for (@order) { + next unless defined $resp{$_}; + push(@pairs, "$_=" . qq("$resp{$_}")); + } + + my $auth_value = "Digest " . join(", ", @pairs); + return $auth_value; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Authen/Ntlm.pm b/Master/tlpkg/tlperl/lib/LWP/Authen/Ntlm.pm new file mode 100644 index 00000000000..d0e560b7b56 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Authen/Ntlm.pm @@ -0,0 +1,180 @@ +package LWP::Authen::Ntlm; + +use strict; +use vars qw/$VERSION/; + +$VERSION = '5.835'; + +use Authen::NTLM "1.02"; +use MIME::Base64 "2.12"; + +sub authenticate { + my($class, $ua, $proxy, $auth_param, $response, + $request, $arg, $size) = @_; + + my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm}, + $request->uri, $proxy); + + unless(defined $user and defined $pass) { + return $response; + } + + if (!$ua->conn_cache()) { + warn "The keep_alive option must be enabled for NTLM authentication to work. NTLM authentication aborted.\n"; + return $response; + } + + my($domain, $username) = split(/\\/, $user); + + ntlm_domain($domain); + ntlm_user($username); + ntlm_password($pass); + + my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization"; + + # my ($challenge) = $response->header('WWW-Authenticate'); + my $challenge; + foreach ($response->header('WWW-Authenticate')) { + last if /^NTLM/ && ($challenge=$_); + } + + if ($challenge eq 'NTLM') { + # First phase, send handshake + my $auth_value = "NTLM " . ntlm(); + ntlm_reset(); + + # Need to check this isn't a repeated fail! + my $r = $response; + my $retry_count = 0; + while ($r) { + my $auth = $r->request->header($auth_header); + ++$retry_count if ($auth && $auth eq $auth_value); + if ($retry_count > 2) { + # here we know this failed before + $response->header("Client-Warning" => + "Credentials for '$user' failed before"); + return $response; + } + $r = $r->previous; + } + + my $referral = $request->clone; + $referral->header($auth_header => $auth_value); + return $ua->request($referral, $arg, $size, $response); + } + + else { + # Second phase, use the response challenge (unless non-401 code + # was returned, in which case, we just send back the response + # object, as is + my $auth_value; + if ($response->code ne '401') { + return $response; + } + else { + my $challenge; + foreach ($response->header('WWW-Authenticate')) { + last if /^NTLM/ && ($challenge=$_); + } + $challenge =~ s/^NTLM //; + ntlm(); + $auth_value = "NTLM " . ntlm($challenge); + ntlm_reset(); + } + + my $referral = $request->clone; + $referral->header($auth_header => $auth_value); + my $response2 = $ua->request($referral, $arg, $size, $response); + return $response2; + } +} + +1; + + +=head1 NAME + +LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP + +=head1 SYNOPSIS + + use LWP::UserAgent; + use HTTP::Request::Common; + my $url = 'http://www.company.com/protected_page.html'; + + # Set up the ntlm client and then the base64 encoded ntlm handshake message + my $ua = LWP::UserAgent->new(keep_alive=>1); + $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword'); + + $request = GET $url; + print "--Performing request now...-----------\n"; + $response = $ua->request($request); + print "--Done with request-------------------\n"; + + if ($response->is_success) {print "It worked!->" . $response->code . "\n"} + else {print "It didn't work!->" . $response->code . "\n"} + +=head1 DESCRIPTION + +C<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the +NTLM authentication scheme popularized by Microsoft. This type of authentication is +common on intranets of Microsoft-centric organizations. + +The module takes advantage of the Authen::NTLM module by Mark Bush. Since there +is also another Authen::NTLM module available from CPAN by Yee Man Chan with an +entirely different interface, it is necessary to ensure that you have the correct +NTLM module. + +In addition, there have been problems with incompatibilities between different +versions of Mime::Base64, which Bush's Authen::NTLM makes use of. Therefore, it is +necessary to ensure that your Mime::Base64 module supports exporting of the +encode_base64 and decode_base64 functions. + +=head1 USAGE + +The module is used indirectly through LWP, rather than including it directly in your +code. The LWP system will invoke the NTLM authentication when it encounters the +authentication scheme while attempting to retrieve a URL from a server. In order +for the NTLM authentication to work, you must have a few things set up in your +code prior to attempting to retrieve the URL: + +=over 4 + +=item * + +Enable persistent HTTP connections + +To do this, pass the "keep_alive=>1" option to the LWP::UserAgent when creating it, like this: + + my $ua = LWP::UserAgent->new(keep_alive=>1); + +=item * + +Set the credentials on the UserAgent object + +The credentials must be set like this: + + $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword'); + +Note that you cannot use the HTTP::Request object's authorization_basic() method to set +the credentials. Note, too, that the 'www.company.com:80' portion only sets credentials +on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and +has nothing to do with LWP::Authen::Ntlm) + +=back + +=head1 AVAILABILITY + +General queries regarding LWP should be made to the LWP Mailing List. + +Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com + +=head1 COPYRIGHT + +Copyright (c) 2002 James Tillman. All rights reserved. This +program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<LWP>, L<LWP::UserAgent>, L<lwpcook>. diff --git a/Master/tlpkg/tlperl/lib/LWP/ConnCache.pm b/Master/tlpkg/tlperl/lib/LWP/ConnCache.pm new file mode 100644 index 00000000000..6ac55cedd40 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/ConnCache.pm @@ -0,0 +1,310 @@ +package LWP::ConnCache; + +use strict; +use vars qw($VERSION $DEBUG); + +$VERSION = "5.810"; + + +sub new { + my($class, %cnf) = @_; + my $total_capacity = delete $cnf{total_capacity}; + $total_capacity = 1 unless defined $total_capacity; + if (%cnf && $^W) { + require Carp; + Carp::carp("Unrecognised options: @{[sort keys %cnf]}") + } + my $self = bless { cc_conns => [] }, $class; + $self->total_capacity($total_capacity); + $self; +} + + +sub deposit { + my($self, $type, $key, $conn) = @_; + push(@{$self->{cc_conns}}, [$conn, $type, $key, time]); + $self->enforce_limits($type); + return; +} + + +sub withdraw { + my($self, $type, $key) = @_; + my $conns = $self->{cc_conns}; + for my $i (0 .. @$conns - 1) { + my $c = $conns->[$i]; + next unless $c->[1] eq $type && $c->[2] eq $key; + splice(@$conns, $i, 1); # remove it + return $c->[0]; + } + return undef; +} + + +sub total_capacity { + my $self = shift; + my $old = $self->{cc_limit_total}; + if (@_) { + $self->{cc_limit_total} = shift; + $self->enforce_limits; + } + $old; +} + + +sub capacity { + my $self = shift; + my $type = shift; + my $old = $self->{cc_limit}{$type}; + if (@_) { + $self->{cc_limit}{$type} = shift; + $self->enforce_limits($type); + } + $old; +} + + +sub enforce_limits { + my($self, $type) = @_; + my $conns = $self->{cc_conns}; + + my @types = $type ? ($type) : ($self->get_types); + for $type (@types) { + next unless $self->{cc_limit}; + my $limit = $self->{cc_limit}{$type}; + next unless defined $limit; + for my $i (reverse 0 .. @$conns - 1) { + next unless $conns->[$i][1] eq $type; + if (--$limit < 0) { + $self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded"); + } + } + } + + if (defined(my $total = $self->{cc_limit_total})) { + while (@$conns > $total) { + $self->dropping(shift(@$conns), "Total capacity exceeded"); + } + } +} + + +sub dropping { + my($self, $c, $reason) = @_; + print "DROPPING @$c [$reason]\n" if $DEBUG; +} + + +sub drop { + my($self, $checker, $reason) = @_; + if (ref($checker) ne "CODE") { + # make it so + if (!defined $checker) { + $checker = sub { 1 }; # drop all of them + } + elsif (_looks_like_number($checker)) { + my $age_limit = $checker; + my $time_limit = time - $age_limit; + $reason ||= "older than $age_limit"; + $checker = sub { $_[3] < $time_limit }; + } + else { + my $type = $checker; + $reason ||= "drop $type"; + $checker = sub { $_[1] eq $type }; # match on type + } + } + $reason ||= "drop"; + + local $SIG{__DIE__}; # don't interfere with eval below + local $@; + my @c; + for (@{$self->{cc_conns}}) { + my $drop; + eval { + if (&$checker(@$_)) { + $self->dropping($_, $reason); + $drop++; + } + }; + push(@c, $_) unless $drop; + } + @{$self->{cc_conns}} = @c; +} + + +sub prune { + my $self = shift; + $self->drop(sub { !shift->ping }, "ping"); +} + + +sub get_types { + my $self = shift; + my %t; + $t{$_->[1]}++ for @{$self->{cc_conns}}; + return keys %t; +} + + +sub get_connections { + my($self, $type) = @_; + my @c; + for (@{$self->{cc_conns}}) { + push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]); + } + @c; +} + + +sub _looks_like_number { + $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; +} + +1; + + +__END__ + +=head1 NAME + +LWP::ConnCache - Connection cache manager + +=head1 NOTE + +This module is experimental. Details of its interface is likely to +change in the future. + +=head1 SYNOPSIS + + use LWP::ConnCache; + my $cache = LWP::ConnCache->new; + $cache->deposit($type, $key, $sock); + $sock = $cache->withdraw($type, $key); + +=head1 DESCRIPTION + +The C<LWP::ConnCache> class is the standard connection cache manager +for LWP::UserAgent. + +The following basic methods are provided: + +=over + +=item $cache = LWP::ConnCache->new( %options ) + +This method constructs a new C<LWP::ConnCache> object. The only +option currently accepted is 'total_capacity'. If specified it +initialize the total_capacity option. It defaults to the value 1. + +=item $cache->total_capacity( [$num_connections] ) + +Get/sets the number of connection that will be cached. Connections +will start to be dropped when this limit is reached. If set to C<0>, +then all connections are immediately dropped. If set to C<undef>, +then there is no limit. + +=item $cache->capacity($type, [$num_connections] ) + +Get/set a limit for the number of connections of the specified type +that can be cached. The $type will typically be a short string like +"http" or "ftp". + +=item $cache->drop( [$checker, [$reason]] ) + +Drop connections by some criteria. The $checker argument is a +subroutine that is called for each connection. If the routine returns +a TRUE value then the connection is dropped. The routine is called +with ($conn, $type, $key, $deposit_time) as arguments. + +Shortcuts: If the $checker argument is absent (or C<undef>) all cached +connections are dropped. If the $checker is a number then all +connections untouched that the given number of seconds or more are +dropped. If $checker is a string then all connections of the given +type are dropped. + +The $reason argument is passed on to the dropped() method. + +=item $cache->prune + +Calling this method will drop all connections that are dead. This is +tested by calling the ping() method on the connections. If the ping() +method exists and returns a FALSE value, then the connection is +dropped. + +=item $cache->get_types + +This returns all the 'type' fields used for the currently cached +connections. + +=item $cache->get_connections( [$type] ) + +This returns all connection objects of the specified type. If no type +is specified then all connections are returned. In scalar context the +number of cached connections of the specified type is returned. + +=back + + +The following methods are called by low-level protocol modules to +try to save away connections and to get them back. + +=over + +=item $cache->deposit($type, $key, $conn) + +This method adds a new connection to the cache. As a result other +already cached connections might be dropped. Multiple connections with +the same $type/$key might added. + +=item $conn = $cache->withdraw($type, $key) + +This method tries to fetch back a connection that was previously +deposited. If no cached connection with the specified $type/$key is +found, then C<undef> is returned. There is not guarantee that a +deposited connection can be withdrawn, as the cache manger is free to +drop connections at any time. + +=back + +The following methods are called internally. Subclasses might want to +override them. + +=over + +=item $conn->enforce_limits([$type]) + +This method is called with after a new connection is added (deposited) +in the cache or capacity limits are adjusted. The default +implementation drops connections until the specified capacity limits +are not exceeded. + +=item $conn->dropping($conn_record, $reason) + +This method is called when a connection is dropped. The record +belonging to the dropped connection is passed as the first argument +and a string describing the reason for the drop is passed as the +second argument. The default implementation makes some noise if the +$LWP::ConnCache::DEBUG variable is set and nothing more. + +=back + +=head1 SUBCLASSING + +For specialized cache policy it makes sense to subclass +C<LWP::ConnCache> and perhaps override the deposit(), enforce_limits() +and dropping() methods. + +The object itself is a hash. Keys prefixed with C<cc_> are reserved +for the base class. + +=head1 SEE ALSO + +L<LWP::UserAgent> + +=head1 COPYRIGHT + +Copyright 2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/LWP/Debug.pm b/Master/tlpkg/tlperl/lib/LWP/Debug.pm new file mode 100644 index 00000000000..f583c527071 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Debug.pm @@ -0,0 +1,110 @@ +package LWP::Debug; # legacy + +require Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(level trace debug conns); + +use Carp (); + +my @levels = qw(trace debug conns); +%current_level = (); + + +sub import +{ + my $pack = shift; + my $callpkg = caller(0); + my @symbols = (); + my @levels = (); + for (@_) { + if (/^[-+]/) { + push(@levels, $_); + } + else { + push(@symbols, $_); + } + } + Exporter::export($pack, $callpkg, @symbols); + level(@levels); +} + + +sub level +{ + for (@_) { + if ($_ eq '+') { # all on + # switch on all levels + %current_level = map { $_ => 1 } @levels; + } + elsif ($_ eq '-') { # all off + %current_level = (); + } + elsif (/^([-+])(\w+)$/) { + $current_level{$2} = $1 eq '+'; + } + else { + Carp::croak("Illegal level format $_"); + } + } +} + + +sub trace { _log(@_) if $current_level{'trace'}; } +sub debug { _log(@_) if $current_level{'debug'}; } +sub conns { _log(@_) if $current_level{'conns'}; } + + +sub _log +{ + my $msg = shift; + $msg .= "\n" unless $msg =~ /\n$/; # ensure trailing "\n" + + my($package,$filename,$line,$sub) = caller(2); + print STDERR "$sub: $msg"; +} + +1; + +__END__ + +=head1 NAME + +LWP::Debug - deprecated + +=head1 DESCRIPTION + +LWP::Debug used to provide tracing facilities, but these are not used +by LWP any more. The code in this module is kept around +(undocumented) so that 3rd party code that happen to use the old +interfaces continue to run. + +One useful feature that LWP::Debug provided (in an imprecise and +troublesome way) was network traffic monitoring. The following +section provide some hints about recommened replacements. + +=head2 Network traffic monitoring + +The best way to monitor the network traffic that LWP generates is to +use an external TCP monitoring program. The Wireshark program +(L<http://www.wireshark.org/>) is higly recommended for this. + +Another approach it to use a debugging HTTP proxy server and make +LWP direct all its traffic via this one. Call C<< $ua->proxy >> to +set it up and then just use LWP as before. + +For less precise monitoring needs just setting up a few simple +handlers might do. The following example sets up handlers to dump the +request and response objects that pass through LWP: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable()); + + $ua->add_handler("request_send", sub { shift->dump; return }); + $ua->add_handler("response_done", sub { shift->dump; return }); + + $ua->get("http://www.example.com"); + +=head1 SEE ALSO + +L<LWP::UserAgent> diff --git a/Master/tlpkg/tlperl/lib/LWP/DebugFile.pm b/Master/tlpkg/tlperl/lib/LWP/DebugFile.pm new file mode 100644 index 00000000000..aacdfca0fe5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/DebugFile.pm @@ -0,0 +1,5 @@ +package LWP::DebugFile; + +# legacy stub + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/MediaTypes.pm b/Master/tlpkg/tlperl/lib/LWP/MediaTypes.pm new file mode 100644 index 00000000000..f7fc671a5bc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/MediaTypes.pm @@ -0,0 +1,298 @@ +package LWP::MediaTypes; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(guess_media_type media_suffix); +@EXPORT_OK = qw(add_type add_encoding read_media_types); +$VERSION = "5.835"; + +use strict; + +# note: These hashes will also be filled with the entries found in +# the 'media.types' file. + +my %suffixType = ( + 'txt' => 'text/plain', + 'html' => 'text/html', + 'gif' => 'image/gif', + 'jpg' => 'image/jpeg', + 'xml' => 'text/xml', +); + +my %suffixExt = ( + 'text/plain' => 'txt', + 'text/html' => 'html', + 'image/gif' => 'gif', + 'image/jpeg' => 'jpg', + 'text/xml' => 'xml', +); + +#XXX: there should be some way to define this in the media.types files. +my %suffixEncoding = ( + 'Z' => 'compress', + 'gz' => 'gzip', + 'hqx' => 'x-hqx', + 'uu' => 'x-uuencode', + 'z' => 'x-pack', + 'bz2' => 'x-bzip2', +); + +read_media_types(); + + + +sub _dump { + require Data::Dumper; + Data::Dumper->new([\%suffixType, \%suffixExt, \%suffixEncoding], + [qw(*suffixType *suffixExt *suffixEncoding)])->Dump; +} + + +sub guess_media_type +{ + my($file, $header) = @_; + return undef unless defined $file; + + my $fullname; + if (ref($file)) { + # assume URI object + $file = $file->path; + #XXX should handle non http:, file: or ftp: URIs differently + } + else { + $fullname = $file; # enable peek at actual file + } + + my @encoding = (); + my $ct = undef; + for (file_exts($file)) { + # first check this dot part as encoding spec + if (exists $suffixEncoding{$_}) { + unshift(@encoding, $suffixEncoding{$_}); + next; + } + if (exists $suffixEncoding{lc $_}) { + unshift(@encoding, $suffixEncoding{lc $_}); + next; + } + + # check content-type + if (exists $suffixType{$_}) { + $ct = $suffixType{$_}; + last; + } + if (exists $suffixType{lc $_}) { + $ct = $suffixType{lc $_}; + last; + } + + # don't know nothing about this dot part, bail out + last; + } + unless (defined $ct) { + # Take a look at the file + if (defined $fullname) { + $ct = (-T $fullname) ? "text/plain" : "application/octet-stream"; + } + else { + $ct = "application/octet-stream"; + } + } + + if ($header) { + $header->header('Content-Type' => $ct); + $header->header('Content-Encoding' => \@encoding) if @encoding; + } + + wantarray ? ($ct, @encoding) : $ct; +} + + +sub media_suffix { + if (!wantarray && @_ == 1 && $_[0] !~ /\*/) { + return $suffixExt{lc $_[0]}; + } + my(@type) = @_; + my(@suffix, $ext, $type); + foreach (@type) { + if (s/\*/.*/) { + while(($ext,$type) = each(%suffixType)) { + push(@suffix, $ext) if $type =~ /^$_$/i; + } + } + else { + my $ltype = lc $_; + while(($ext,$type) = each(%suffixType)) { + push(@suffix, $ext) if lc $type eq $ltype; + } + } + } + wantarray ? @suffix : $suffix[0]; +} + + +sub file_exts +{ + require File::Basename; + my @parts = reverse split(/\./, File::Basename::basename($_[0])); + pop(@parts); # never consider first part + @parts; +} + + +sub add_type +{ + my($type, @exts) = @_; + for my $ext (@exts) { + $ext =~ s/^\.//; + $suffixType{$ext} = $type; + } + $suffixExt{lc $type} = $exts[0] if @exts; +} + + +sub add_encoding +{ + my($type, @exts) = @_; + for my $ext (@exts) { + $ext =~ s/^\.//; + $suffixEncoding{$ext} = $type; + } +} + + +sub read_media_types +{ + my(@files) = @_; + + local($/, $_) = ("\n", undef); # ensure correct $INPUT_RECORD_SEPARATOR + + my @priv_files = (); + if($^O eq "MacOS") { + push(@priv_files, "$ENV{HOME}:media.types", "$ENV{HOME}:mime.types") + if defined $ENV{HOME}; # Some does not have a home (for instance Win32) + } + else { + push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types") + if defined $ENV{HOME}; # Some doesn't have a home (for instance Win32) + } + + # Try to locate "media.types" file, and initialize %suffixType from it + my $typefile; + unless (@files) { + if($^O eq "MacOS") { + @files = map {$_."LWP:media.types"} @INC; + } + else { + @files = map {"$_/LWP/media.types"} @INC; + } + push @files, @priv_files; + } + for $typefile (@files) { + local(*TYPE); + open(TYPE, $typefile) || next; + while (<TYPE>) { + next if /^\s*#/; # comment line + next if /^\s*$/; # blank line + s/#.*//; # remove end-of-line comments + my($type, @exts) = split(' ', $_); + add_type($type, @exts); + } + close(TYPE); + } +} + +1; + + +__END__ + +=head1 NAME + +LWP::MediaTypes - guess media type for a file or a URL + +=head1 SYNOPSIS + + use LWP::MediaTypes qw(guess_media_type); + $type = guess_media_type("/tmp/foo.gif"); + +=head1 DESCRIPTION + +This module provides functions for handling media (also known as +MIME) types and encodings. The mapping from file extensions to media +types is defined by the F<media.types> file. If the F<~/.media.types> +file exists it is used instead. +For backwards compatibility we will also look for F<~/.mime.types>. + +The following functions are exported by default: + +=over 4 + +=item guess_media_type( $filename ) + +=item guess_media_type( $uri ) + +=item guess_media_type( $filename_or_uri, $header_to_modify ) + +This function tries to guess media type and encoding for a file or a URI. +It returns the content type, which is a string like C<"text/html">. +In array context it also returns any content encodings applied (in the +order used to encode the file). You can pass a URI object +reference, instead of the file name. + +If the type can not be deduced from looking at the file name, +then guess_media_type() will let the C<-T> Perl operator take a look. +If this works (and C<-T> returns a TRUE value) then we return +I<text/plain> as the type, otherwise we return +I<application/octet-stream> as the type. + +The optional second argument should be a reference to a HTTP::Headers +object or any object that implements the $obj->header method in a +similar way. When it is present the values of the +'Content-Type' and 'Content-Encoding' will be set for this header. + +=item media_suffix( $type, ... ) + +This function will return all suffixes that can be used to denote the +specified media type(s). Wildcard types can be used. In a scalar +context it will return the first suffix found. Examples: + + @suffixes = media_suffix('image/*', 'audio/basic'); + $suffix = media_suffix('text/html'); + +=back + +The following functions are only exported by explicit request: + +=over 4 + +=item add_type( $type, @exts ) + +Associate a list of file extensions with the given media type. +Example: + + add_type("x-world/x-vrml" => qw(wrl vrml)); + +=item add_encoding( $type, @ext ) + +Associate a list of file extensions with an encoding type. +Example: + + add_encoding("x-gzip" => "gz"); + +=item read_media_types( @files ) + +Parse media types files and add the type mappings found there. +Example: + + read_media_types("conf/mime.types"); + +=back + +=head1 COPYRIGHT + +Copyright 1995-1999 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl/lib/LWP/MemberMixin.pm b/Master/tlpkg/tlperl/lib/LWP/MemberMixin.pm new file mode 100644 index 00000000000..e5ee6f6382e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/MemberMixin.pm @@ -0,0 +1,44 @@ +package LWP::MemberMixin; + +sub _elem +{ + my $self = shift; + my $elem = shift; + my $old = $self->{$elem}; + $self->{$elem} = shift if @_; + return $old; +} + +1; + +__END__ + +=head1 NAME + +LWP::MemberMixin - Member access mixin class + +=head1 SYNOPSIS + + package Foo; + require LWP::MemberMixin; + @ISA=qw(LWP::MemberMixin); + +=head1 DESCRIPTION + +A mixin class to get methods that provide easy access to member +variables in the %$self. +Ideally there should be better Perl language support for this. + +There is only one method provided: + +=over 4 + +=item _elem($elem [, $val]) + +Internal method to get/set the value of member variable +C<$elem>. If C<$val> is present it is used as the new value +for the member variable. If it is not present the current +value is not touched. In both cases the previous value of +the member variable is returned. + +=back diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol.pm new file mode 100644 index 00000000000..61a28cd1386 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol.pm @@ -0,0 +1,291 @@ +package LWP::Protocol; + +require LWP::MemberMixin; +@ISA = qw(LWP::MemberMixin); +$VERSION = "5.829"; + +use strict; +use Carp (); +use HTTP::Status (); +use HTTP::Response; + +my %ImplementedBy = (); # scheme => classname + + + +sub new +{ + my($class, $scheme, $ua) = @_; + + my $self = bless { + scheme => $scheme, + ua => $ua, + + # historical/redundant + max_size => $ua->{max_size}, + }, $class; + + $self; +} + + +sub create +{ + my($scheme, $ua) = @_; + my $impclass = LWP::Protocol::implementor($scheme) or + Carp::croak("Protocol scheme '$scheme' is not supported"); + + # hand-off to scheme specific implementation sub-class + my $protocol = $impclass->new($scheme, $ua); + + return $protocol; +} + + +sub implementor +{ + my($scheme, $impclass) = @_; + + if ($impclass) { + $ImplementedBy{$scheme} = $impclass; + } + my $ic = $ImplementedBy{$scheme}; + return $ic if $ic; + + return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes + $scheme = $1; # untaint + $scheme =~ s/[.+\-]/_/g; # make it a legal module name + + # scheme not yet known, look for a 'use'd implementation + $ic = "LWP::Protocol::$scheme"; # default location + $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack + no strict 'refs'; + # check we actually have one for the scheme: + unless (@{"${ic}::ISA"}) { + # try to autoload it + eval "require $ic"; + if ($@) { + if ($@ =~ /Can't locate/) { #' #emacs get confused by ' + $ic = ''; + } + else { + die "$@\n"; + } + } + } + $ImplementedBy{$scheme} = $ic if $ic; + $ic; +} + + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses'); +} + + +# legacy +sub timeout { shift->_elem('timeout', @_); } +sub max_size { shift->_elem('max_size', @_); } + + +sub collect +{ + my ($self, $arg, $response, $collector) = @_; + my $content; + my($ua, $max_size) = @{$self}{qw(ua max_size)}; + + eval { + local $\; # protect the print below from surprises + if (!defined($arg) || !$response->is_success) { + $response->{default_add_content} = 1; + } + elsif (!ref($arg) && length($arg)) { + open(my $fh, ">", $arg) or die "Can't write to '$arg': $!"; + binmode($fh); + push(@{$response->{handlers}{response_data}}, { + callback => sub { + print $fh $_[3] or die "Can't write to '$arg': $!"; + 1; + }, + }); + push(@{$response->{handlers}{response_done}}, { + callback => sub { + close($fh) or die "Can't write to '$arg': $!"; + undef($fh); + }, + }); + } + elsif (ref($arg) eq 'CODE') { + push(@{$response->{handlers}{response_data}}, { + callback => sub { + &$arg($_[3], $_[0], $self); + 1; + }, + }); + } + else { + die "Unexpected collect argument '$arg'"; + } + + $ua->run_handlers("response_header", $response); + + if (delete $response->{default_add_content}) { + push(@{$response->{handlers}{response_data}}, { + callback => sub { + $_[0]->add_content($_[3]); + 1; + }, + }); + } + + + my $content_size = 0; + my $length = $response->content_length; + my %skip_h; + + while ($content = &$collector, length $$content) { + for my $h ($ua->handlers("response_data", $response)) { + next if $skip_h{$h}; + unless ($h->{callback}->($response, $ua, $h, $$content)) { + # XXX remove from $response->{handlers}{response_data} if present + $skip_h{$h}++; + } + } + $content_size += length($$content); + $ua->progress(($length ? ($content_size / $length) : "tick"), $response); + if (defined($max_size) && $content_size > $max_size) { + $response->push_header("Client-Aborted", "max_size"); + last; + } + } + }; + my $err = $@; + delete $response->{handlers}{response_data}; + delete $response->{handlers} unless %{$response->{handlers}}; + if ($err) { + chomp($err); + $response->push_header('X-Died' => $err); + $response->push_header("Client-Aborted", "die"); + return $response; + } + + return $response; +} + + +sub collect_once +{ + my($self, $arg, $response) = @_; + my $content = \ $_[3]; + my $first = 1; + $self->collect($arg, $response, sub { + return $content if $first--; + return \ ""; + }); +} + +1; + + +__END__ + +=head1 NAME + +LWP::Protocol - Base class for LWP protocols + +=head1 SYNOPSIS + + package LWP::Protocol::foo; + require LWP::Protocol; + @ISA=qw(LWP::Protocol); + +=head1 DESCRIPTION + +This class is used a the base class for all protocol implementations +supported by the LWP library. + +When creating an instance of this class using +C<LWP::Protocol::create($url)>, and you get an initialised subclass +appropriate for that access method. In other words, the +LWP::Protocol::create() function calls the constructor for one of its +subclasses. + +All derived LWP::Protocol classes need to override the request() +method which is used to service a request. The overridden method can +make use of the collect() function to collect together chunks of data +as it is received. + +The following methods and functions are provided: + +=over 4 + +=item $prot = LWP::Protocol->new() + +The LWP::Protocol constructor is inherited by subclasses. As this is a +virtual base class this method should B<not> be called directly. + +=item $prot = LWP::Protocol::create($scheme) + +Create an object of the class implementing the protocol to handle the +given scheme. This is a function, not a method. It is more an object +factory than a constructor. This is the function user agents should +use to access protocols. + +=item $class = LWP::Protocol::implementor($scheme, [$class]) + +Get and/or set implementor class for a scheme. Returns '' if the +specified scheme is not supported. + +=item $prot->request(...) + + $response = $protocol->request($request, $proxy, undef); + $response = $protocol->request($request, $proxy, '/tmp/sss'); + $response = $protocol->request($request, $proxy, \&callback, 1024); + +Dispatches a request over the protocol, and returns a response +object. This method needs to be overridden in subclasses. Refer to +L<LWP::UserAgent> for description of the arguments. + +=item $prot->collect($arg, $response, $collector) + +Called to collect the content of a request, and process it +appropriately into a scalar, file, or by calling a callback. If $arg +is undefined, then the content is stored within the $response. If +$arg is a simple scalar, then $arg is interpreted as a file name and +the content is written to this file. If $arg is a reference to a +routine, then content is passed to this routine. + +The $collector is a routine that will be called and which is +responsible for returning pieces (as ref to scalar) of the content to +process. The $collector signals EOF by returning a reference to an +empty sting. + +The return value from collect() is the $response object reference. + +B<Note:> We will only use the callback or file argument if +$response->is_success(). This avoids sending content data for +redirects and authentication responses to the callback which would be +confusing. + +=item $prot->collect_once($arg, $response, $content) + +Can be called when the whole response content is available as +$content. This will invoke collect() with a collector callback that +returns a reference to $content the first time and an empty string the +next. + +=back + +=head1 SEE ALSO + +Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files +for examples of usage. + +=head1 COPYRIGHT + +Copyright 1995-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/GHTTP.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/GHTTP.pm new file mode 100644 index 00000000000..2a356b5fcb1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/GHTTP.pm @@ -0,0 +1,73 @@ +package LWP::Protocol::GHTTP; + +# You can tell LWP to use this module for 'http' requests by running +# code like this before you make requests: +# +# require LWP::Protocol::GHTTP; +# LWP::Protocol::implementor('http', 'LWP::Protocol::GHTTP'); +# + +use strict; +use vars qw(@ISA); + +require LWP::Protocol; +@ISA=qw(LWP::Protocol); + +require HTTP::Response; +require HTTP::Status; + +use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST); + +my %METHOD = +( + GET => METHOD_GET, + HEAD => METHOD_HEAD, + POST => METHOD_POST, +); + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + my $method = $request->method; + unless (exists $METHOD{$method}) { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + "Bad method '$method'"); + } + + my $r = HTTP::GHTTP->new($request->uri); + + # XXX what headers for repeated headers here? + $request->headers->scan(sub { $r->set_header(@_)}); + + $r->set_type($METHOD{$method}); + + # XXX should also deal with subroutine content. + my $cref = $request->content_ref; + $r->set_body($$cref) if length($$cref); + + # XXX is this right + $r->set_proxy($proxy->as_string) if $proxy; + + $r->process_request; + + my $response = HTTP::Response->new($r->get_status); + + # XXX How can get the headers out of $r?? This way is too stupid. + my @headers; + eval { + # Wrapped in eval because this method is not always available + @headers = $r->get_headers; + }; + @headers = qw(Date Connection Server Content-type + Accept-Ranges Server + Content-Length Last-Modified ETag) if $@; + for (@headers) { + my $v = $r->get_header($_); + $response->header($_ => $v) if defined $v; + } + + return $self->collect_once($arg, $response, $r->get_body); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm new file mode 100644 index 00000000000..66d8f213b98 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm @@ -0,0 +1,72 @@ +package LWP::Protocol::cpan; + +use strict; +use vars qw(@ISA); + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +require URI; +require HTTP::Status; +require HTTP::Response; + +our $CPAN; + +unless ($CPAN) { + # Try to find local CPAN mirror via $CPAN::Config + eval { + require CPAN::Config; + if($CPAN::Config) { + my $urls = $CPAN::Config->{urllist}; + if (ref($urls) eq "ARRAY") { + my $file; + for (@$urls) { + if (/^file:/) { + $file = $_; + last; + } + } + + if ($file) { + $CPAN = $file; + } + else { + $CPAN = $urls->[0]; + } + } + } + }; + + $CPAN ||= "http://cpan.org/"; # last resort +} + +# ensure that we don't chop of last part +$CPAN .= "/" unless $CPAN =~ m,/$,; + + +sub request { + my($self, $request, $proxy, $arg, $size) = @_; + # check proxy + if (defined $proxy) + { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy with cpan'); + } + + # check method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'cpan:' URLs"); + } + + my $path = $request->uri->path; + $path =~ s,^/,,; + + my $response = HTTP::Response->new(&HTTP::Status::RC_FOUND); + $response->header("Location" => URI->new_abs($path, $CPAN)); + $response; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/data.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/data.pm new file mode 100644 index 00000000000..c29c3b4f919 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/data.pm @@ -0,0 +1,52 @@ +package LWP::Protocol::data; + +# Implements access to data:-URLs as specified in RFC 2397 + +use strict; +use vars qw(@ISA); + +require HTTP::Response; +require HTTP::Status; + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +use HTTP::Date qw(time2str); +require LWP; # needs version number + +sub request +{ + my($self, $request, $proxy, $arg, $size) = @_; + + # check proxy + if (defined $proxy) + { + return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy with data'); + } + + # check method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'data:' URLs"); + } + + my $url = $request->uri; + my $response = HTTP::Response->new( &HTTP::Status::RC_OK, "Document follows"); + + my $media_type = $url->media_type; + + my $data = $url->data; + $response->header('Content-Type' => $media_type, + 'Content-Length' => length($data), + 'Date' => time2str(time), + 'Server' => "libwww-perl-internal/$LWP::VERSION" + ); + + $data = "" if $method eq "HEAD"; + return $self->collect_once($arg, $response, $data); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm new file mode 100644 index 00000000000..f2887f4b2f3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm @@ -0,0 +1,146 @@ +package LWP::Protocol::file; + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +use strict; + +require LWP::MediaTypes; +require HTTP::Request; +require HTTP::Response; +require HTTP::Status; +require HTTP::Date; + + +sub request +{ + my($self, $request, $proxy, $arg, $size) = @_; + + $size = 4096 unless defined $size and $size > 0; + + # check proxy + if (defined $proxy) + { + return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through the filesystem'); + } + + # check method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'file:' URLs"); + } + + # check url + my $url = $request->uri; + + my $scheme = $url->scheme; + if ($scheme ne 'file') { + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::file::request called for '$scheme'"); + } + + # URL OK, look at file + my $path = $url->file; + + # test file exists and is readable + unless (-e $path) { + return HTTP::Response->new( &HTTP::Status::RC_NOT_FOUND, + "File `$path' does not exist"); + } + unless (-r _) { + return HTTP::Response->new( &HTTP::Status::RC_FORBIDDEN, + 'User does not have read permission'); + } + + # looks like file exists + my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat(_); + + # XXX should check Accept headers? + + # check if-modified-since + my $ims = $request->header('If-Modified-Since'); + if (defined $ims) { + my $time = HTTP::Date::str2time($ims); + if (defined $time and $time >= $mtime) { + return HTTP::Response->new( &HTTP::Status::RC_NOT_MODIFIED, + "$method $path"); + } + } + + # Ok, should be an OK response by now... + my $response = HTTP::Response->new( &HTTP::Status::RC_OK ); + + # fill in response headers + $response->header('Last-Modified', HTTP::Date::time2str($mtime)); + + if (-d _) { # If the path is a directory, process it + # generate the HTML for directory + opendir(D, $path) or + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Cannot read directory '$path': $!"); + my(@files) = sort readdir(D); + closedir(D); + + # Make directory listing + require URI::Escape; + require HTML::Entities; + my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/'); + for (@files) { + my $furl = URI::Escape::uri_escape($_); + if ( -d "$pathe$_" ) { + $furl .= '/'; + $_ .= '/'; + } + my $desc = HTML::Entities::encode($_); + $_ = qq{<LI><A HREF="$furl">$desc</A>}; + } + # Ensure that the base URL is "/" terminated + my $base = $url->clone; + unless ($base->path =~ m|/$|) { + $base->path($base->path . "/"); + } + my $html = join("\n", + "<HTML>\n<HEAD>", + "<TITLE>Directory $path</TITLE>", + "<BASE HREF=\"$base\">", + "</HEAD>\n<BODY>", + "<H1>Directory listing of $path</H1>", + "<UL>", @files, "</UL>", + "</BODY>\n</HTML>\n"); + + $response->header('Content-Type', 'text/html'); + $response->header('Content-Length', length $html); + $html = "" if $method eq "HEAD"; + + return $self->collect_once($arg, $response, $html); + + } + + # path is a regular file + $response->header('Content-Length', $filesize); + LWP::MediaTypes::guess_media_type($path, $response); + + # read the file + if ($method ne "HEAD") { + open(F, $path) or return new + HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Cannot read file '$path': $!"); + binmode(F); + $response = $self->collect($arg, $response, sub { + my $content = ""; + my $bytes = sysread(F, $content, $size); + return \$content if $bytes > 0; + return \ ""; + }); + close(F); + } + + $response; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/ftp.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/ftp.pm new file mode 100644 index 00000000000..d12acb32374 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/ftp.pm @@ -0,0 +1,543 @@ +package LWP::Protocol::ftp; + +# Implementation of the ftp protocol (RFC 959). We let the Net::FTP +# package do all the dirty work. + +use Carp (); + +use HTTP::Status (); +use HTTP::Negotiate (); +use HTTP::Response (); +use LWP::MediaTypes (); +use File::Listing (); + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +use strict; +eval { + package LWP::Protocol::MyFTP; + + require Net::FTP; + Net::FTP->require_version(2.00); + + use vars qw(@ISA); + @ISA=qw(Net::FTP); + + sub new { + my $class = shift; + + my $self = $class->SUPER::new(@_) || return undef; + + my $mess = $self->message; # welcome message + $mess =~ s|\n.*||s; # only first line left + $mess =~ s|\s*ready\.?$||; + # Make the version number more HTTP like + $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||; + ${*$self}{myftp_server} = $mess; + #$response->header("Server", $mess); + + $self; + } + + sub http_server { + my $self = shift; + ${*$self}{myftp_server}; + } + + sub home { + my $self = shift; + my $old = ${*$self}{myftp_home}; + if (@_) { + ${*$self}{myftp_home} = shift; + } + $old; + } + + sub go_home { + my $self = shift; + $self->cwd(${*$self}{myftp_home}); + } + + sub request_count { + my $self = shift; + ++${*$self}{myftp_reqcount}; + } + + sub ping { + my $self = shift; + return $self->go_home; + } + +}; +my $init_failed = $@; + + +sub _connect { + my($self, $host, $port, $user, $account, $password, $timeout) = @_; + + my $key; + my $conn_cache = $self->{ua}{conn_cache}; + if ($conn_cache) { + $key = "$host:$port:$user"; + $key .= ":$account" if defined($account); + if (my $ftp = $conn_cache->withdraw("ftp", $key)) { + if ($ftp->ping) { + # save it again + $conn_cache->deposit("ftp", $key, $ftp); + return $ftp; + } + } + } + + # try to make a connection + my $ftp = LWP::Protocol::MyFTP->new($host, + Port => $port, + Timeout => $timeout, + LocalAddr => $self->{ua}{local_address}, + ); + # XXX Should be some what to pass on 'Passive' (header??) + unless ($ftp) { + $@ =~ s/^Net::FTP: //; + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@); + } + + unless ($ftp->login($user, $password, $account)) { + # Unauthorized. Let's fake a RC_UNAUTHORIZED response + my $mess = scalar($ftp->message); + $mess =~ s/\n$//; + my $res = HTTP::Response->new(&HTTP::Status::RC_UNAUTHORIZED, $mess); + $res->header("Server", $ftp->http_server); + $res->header("WWW-Authenticate", qq(Basic Realm="FTP login")); + return $res; + } + + my $home = $ftp->pwd; + $ftp->home($home); + + $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache; + + return $ftp; +} + + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size = 4096 unless $size; + + # check proxy + if (defined $proxy) + { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through the ftp'); + } + + my $url = $request->uri; + if ($url->scheme ne 'ftp') { + my $scheme = $url->scheme; + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::ftp::request called for '$scheme'"); + } + + # check method + my $method = $request->method; + + unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'ftp:' URLs"); + } + + if ($init_failed) { + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + $init_failed); + } + + my $host = $url->host; + my $port = $url->port; + my $user = $url->user; + my $password = $url->password; + + # If a basic autorization header is present than we prefer these over + # the username/password specified in the URL. + { + my($u,$p) = $request->authorization_basic; + if (defined $u) { + $user = $u; + $password = $p; + } + } + + # We allow the account to be specified in the "Account" header + my $account = $request->header('Account'); + + my $ftp = $self->_connect($host, $port, $user, $account, $password, $timeout); + return $ftp if ref($ftp) eq "HTTP::Response"; # ugh! + + # Create an initial response object + my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK"); + $response->header(Server => $ftp->http_server); + $response->header('Client-Request-Num' => $ftp->request_count); + $response->request($request); + + # Get & fix the path + my @path = grep { length } $url->path_segments; + my $remote_file = pop(@path); + $remote_file = '' unless defined $remote_file; + + my $type; + if (ref $remote_file) { + my @params; + ($remote_file, @params) = @$remote_file; + for (@params) { + $type = $_ if s/^type=//; + } + } + + if ($type && $type eq 'a') { + $ftp->ascii; + } + else { + $ftp->binary; + } + + for (@path) { + unless ($ftp->cwd($_)) { + return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND, + "Can't chdir to $_"); + } + } + + if ($method eq 'GET' || $method eq 'HEAD') { + if (my $mod_time = $ftp->mdtm($remote_file)) { + $response->last_modified($mod_time); + if (my $ims = $request->if_modified_since) { + if ($mod_time <= $ims) { + $response->code(&HTTP::Status::RC_NOT_MODIFIED); + $response->message("Not modified"); + return $response; + } + } + } + + # We'll use this later to abort the transfer if necessary. + # if $max_size is defined, we need to abort early. Otherwise, it's + # a normal transfer + my $max_size = undef; + + # Set resume location, if the client requested it + if ($request->header('Range') && $ftp->supported('REST')) + { + my $range_info = $request->header('Range'); + + # Change bytes=2772992-6781209 to just 2772992 + my ($start_byte,$end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)?/; + if ( defined $start_byte && !defined $end_byte ) { + + # open range -- only the start is specified + + $ftp->restart( $start_byte ); + # don't define $max_size, we don't want to abort early + } + elsif ( defined $start_byte && defined $end_byte && + $start_byte >= 0 && $end_byte >= $start_byte ) { + + $ftp->restart( $start_byte ); + $max_size = $end_byte - $start_byte; + } + else { + + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'Incorrect syntax for Range request'); + } + } + elsif ($request->header('Range') && !$ftp->supported('REST')) + { + return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED, + "Server does not support resume."); + } + + my $data; # the data handle + if (length($remote_file) and $data = $ftp->retr($remote_file)) { + my($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file); + $response->header('Content-Type', $type) if $type; + for (@enc) { + $response->push_header('Content-Encoding', $_); + } + my $mess = $ftp->message; + if ($mess =~ /\((\d+)\s+bytes\)/) { + $response->header('Content-Length', "$1"); + } + + if ($method ne 'HEAD') { + # Read data from server + $response = $self->collect($arg, $response, sub { + my $content = ''; + my $result = $data->read($content, $size); + + # Stop early if we need to. + if (defined $max_size) + { + # We need an interface to Net::FTP::dataconn for getting + # the number of bytes already read + my $bytes_received = $data->bytes_read(); + + # We were already over the limit. (Should only happen + # once at the end.) + if ($bytes_received - length($content) > $max_size) + { + $content = ''; + } + # We just went over the limit + elsif ($bytes_received > $max_size) + { + # Trim content + $content = substr($content, 0, + $max_size - ($bytes_received - length($content)) ); + } + # We're under the limit + else + { + } + } + + return \$content; + } ); + } + # abort is needed for HEAD, it's == close if the transfer has + # already completed. + unless ($data->abort) { + # Something did not work too well. Note that we treat + # responses to abort() with code 0 in case of HEAD as ok + # (at least wu-ftpd 2.6.1(1) does that). + if ($method ne 'HEAD' || $ftp->code != 0) { + $response->code(&HTTP::Status::RC_INTERNAL_SERVER_ERROR); + $response->message("FTP close response: " . $ftp->code . + " " . $ftp->message); + } + } + } + elsif (!length($remote_file) || ( $ftp->code >= 400 && $ftp->code < 600 )) { + # not a plain file, try to list instead + if (length($remote_file) && !$ftp->cwd($remote_file)) { + return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND, + "File '$remote_file' not found"); + } + + # It should now be safe to try to list the directory + my @lsl = $ftp->dir; + + # Try to figure out if the user want us to convert the + # directory listing to HTML. + my @variants = + ( + ['html', 0.60, 'text/html' ], + ['dir', 1.00, 'text/ftp-dir-listing' ] + ); + #$HTTP::Negotiate::DEBUG=1; + my $prefer = HTTP::Negotiate::choose(\@variants, $request); + + my $content = ''; + + if (!defined($prefer)) { + return HTTP::Response->new(&HTTP::Status::RC_NOT_ACCEPTABLE, + "Neither HTML nor directory listing wanted"); + } + elsif ($prefer eq 'html') { + $response->header('Content-Type' => 'text/html'); + $content = "<HEAD><TITLE>File Listing</TITLE>\n"; + my $base = $request->uri->clone; + my $path = $base->path; + $base->path("$path/") unless $path =~ m|/$|; + $content .= qq(<BASE HREF="$base">\n</HEAD>\n); + $content .= "<BODY>\n<UL>\n"; + for (File::Listing::parse_dir(\@lsl, 'GMT')) { + my($name, $type, $size, $mtime, $mode) = @$_; + $content .= qq( <LI> <a href="$name">$name</a>); + $content .= " $size bytes" if $type eq 'f'; + $content .= "\n"; + } + $content .= "</UL></body>\n"; + } + else { + $response->header('Content-Type', 'text/ftp-dir-listing'); + $content = join("\n", @lsl, ''); + } + + $response->header('Content-Length', length($content)); + + if ($method ne 'HEAD') { + $response = $self->collect_once($arg, $response, $content); + } + } + else { + my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + "FTP return code " . $ftp->code); + $res->content_type("text/plain"); + $res->content($ftp->message); + return $res; + } + } + elsif ($method eq 'PUT') { + # method must be PUT + unless (length($remote_file)) { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + "Must have a file name to PUT to"); + } + my $data; + if ($data = $ftp->stor($remote_file)) { + my $content = $request->content; + my $bytes = 0; + if (defined $content) { + if (ref($content) eq 'SCALAR') { + $bytes = $data->write($$content, length($$content)); + } + elsif (ref($content) eq 'CODE') { + my($buf, $n); + while (length($buf = &$content)) { + $n = $data->write($buf, length($buf)); + last unless $n; + $bytes += $n; + } + } + elsif (!ref($content)) { + if (defined $content && length($content)) { + $bytes = $data->write($content, length($content)); + } + } + else { + die "Bad content"; + } + } + $data->close; + + $response->code(&HTTP::Status::RC_CREATED); + $response->header('Content-Type', 'text/plain'); + $response->content("$bytes bytes stored as $remote_file on $host\n") + + } + else { + my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + "FTP return code " . $ftp->code); + $res->content_type("text/plain"); + $res->content($ftp->message); + return $res; + } + } + else { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + "Illegal method $method"); + } + + $response; +} + +1; + +__END__ + +# This is what RFC 1738 has to say about FTP access: +# -------------------------------------------------- +# +# 3.2. FTP +# +# The FTP URL scheme is used to designate files and directories on +# Internet hosts accessible using the FTP protocol (RFC959). +# +# A FTP URL follow the syntax described in Section 3.1. If :<port> is +# omitted, the port defaults to 21. +# +# 3.2.1. FTP Name and Password +# +# A user name and password may be supplied; they are used in the ftp +# "USER" and "PASS" commands after first making the connection to the +# FTP server. If no user name or password is supplied and one is +# requested by the FTP server, the conventions for "anonymous" FTP are +# to be used, as follows: +# +# The user name "anonymous" is supplied. +# +# The password is supplied as the Internet e-mail address +# of the end user accessing the resource. +# +# If the URL supplies a user name but no password, and the remote +# server requests a password, the program interpreting the FTP URL +# should request one from the user. +# +# 3.2.2. FTP url-path +# +# The url-path of a FTP URL has the following syntax: +# +# <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode> +# +# Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings +# and <typecode> is one of the characters "a", "i", or "d". The part +# ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be +# empty. The whole url-path may be omitted, including the "/" +# delimiting it from the prefix containing user, password, host, and +# port. +# +# The url-path is interpreted as a series of FTP commands as follows: +# +# Each of the <cwd> elements is to be supplied, sequentially, as the +# argument to a CWD (change working directory) command. +# +# If the typecode is "d", perform a NLST (name list) command with +# <name> as the argument, and interpret the results as a file +# directory listing. +# +# Otherwise, perform a TYPE command with <typecode> as the argument, +# and then access the file whose name is <name> (for example, using +# the RETR command.) +# +# Within a name or CWD component, the characters "/" and ";" are +# reserved and must be encoded. The components are decoded prior to +# their use in the FTP protocol. In particular, if the appropriate FTP +# sequence to access a particular file requires supplying a string +# containing a "/" as an argument to a CWD or RETR command, it is +# necessary to encode each "/". +# +# For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is +# interpreted by FTP-ing to "host.dom", logging in as "myname" +# (prompting for a password if it is asked for), and then executing +# "CWD /etc" and then "RETR motd". This has a different meaning from +# <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then +# "RETR motd"; the initial "CWD" might be executed relative to the +# default directory for "myname". On the other hand, +# <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null +# argument, then "CWD etc", and then "RETR motd". +# +# FTP URLs may also be used for other operations; for example, it is +# possible to update a file on a remote file server, or infer +# information about it from the directory listings. The mechanism for +# doing so is not spelled out here. +# +# 3.2.3. FTP Typecode is Optional +# +# The entire ;type=<typecode> part of a FTP URL is optional. If it is +# omitted, the client program interpreting the URL must guess the +# appropriate mode to use. In general, the data content type of a file +# can only be guessed from the name, e.g., from the suffix of the name; +# the appropriate type code to be used for transfer of the file can +# then be deduced from the data content of the file. +# +# 3.2.4 Hierarchy +# +# For some file systems, the "/" used to denote the hierarchical +# structure of the URL corresponds to the delimiter used to construct a +# file name hierarchy, and thus, the filename will look similar to the +# URL path. This does NOT mean that the URL is a Unix filename. +# +# 3.2.5. Optimization +# +# Clients accessing resources via FTP may employ additional heuristics +# to optimize the interaction. For some FTP servers, for example, it +# may be reasonable to keep the control connection open while accessing +# multiple URLs from the same server. However, there is no common +# hierarchical model to the FTP protocol, so if a directory change +# command has been given, it is impossible in general to deduce what +# sequence should be given to navigate to another directory for a +# second retrieval, if the paths are different. The only reliable +# algorithm is to disconnect and reestablish the control connection. diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/gopher.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/gopher.pm new file mode 100644 index 00000000000..db6c0bfba9d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/gopher.pm @@ -0,0 +1,213 @@ +package LWP::Protocol::gopher; + +# Implementation of the gopher protocol (RFC 1436) +# +# This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden' +# which in turn is a vastly modified version of Oscar's http'get() +# dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl> +# including contributions from Marc van Heyningen and Martijn Koster. + +use strict; +use vars qw(@ISA); + +require HTTP::Response; +require HTTP::Status; +require IO::Socket; +require IO::Select; + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + + +my %gopher2mimetype = ( + '0' => 'text/plain', # 0 file + '1' => 'text/html', # 1 menu + # 2 CSO phone-book server + # 3 Error + '4' => 'application/mac-binhex40', # 4 BinHexed Macintosh file + '5' => 'application/zip', # 5 DOS binary archive of some sort + '6' => 'application/octet-stream', # 6 UNIX uuencoded file. + '7' => 'text/html', # 7 Index-Search server + # 8 telnet session + '9' => 'application/octet-stream', # 9 binary file + 'h' => 'text/html', # html + 'g' => 'image/gif', # gif + 'I' => 'image/*', # some kind of image +); + +my %gopher2encoding = ( + '6' => 'x_uuencode', # 6 UNIX uuencoded file. +); + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size = 4096 unless $size; + + # check proxy + if (defined $proxy) { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through the gopher'); + } + + my $url = $request->uri; + die "bad scheme" if $url->scheme ne 'gopher'; + + + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'gopher:' URLs"); + } + + my $gophertype = $url->gopher_type; + unless (exists $gopher2mimetype{$gophertype}) { + return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED, + 'Library does not support gophertype ' . + $gophertype); + } + + my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK"); + $response->header('Content-type' => $gopher2mimetype{$gophertype} + || 'text/plain'); + $response->header('Content-Encoding' => $gopher2encoding{$gophertype}) + if exists $gopher2encoding{$gophertype}; + + if ($method eq 'HEAD') { + # XXX: don't even try it so we set this header + $response->header('Client-Warning' => 'Client answer only'); + return $response; + } + + if ($gophertype eq '7' && ! $url->search) { + # the url is the prompt for a gopher search; supply boiler-plate + return $self->collect_once($arg, $response, <<"EOT"); +<HEAD> +<TITLE>Gopher Index</TITLE> +<ISINDEX> +</HEAD> +<BODY> +<H1>$url<BR>Gopher Search</H1> +This is a searchable Gopher index. +Use the search function of your browser to enter search terms. +</BODY> +EOT + } + + my $host = $url->host; + my $port = $url->port; + + my $requestLine = ""; + + my $selector = $url->selector; + if (defined $selector) { + $requestLine .= $selector; + my $search = $url->search; + if (defined $search) { + $requestLine .= "\t$search"; + my $string = $url->string; + if (defined $string) { + $requestLine .= "\t$string"; + } + } + } + $requestLine .= "\015\012"; + + # potential request headers are just ignored + + # Ok, lets make the request + my $socket = IO::Socket::INET->new(PeerAddr => $host, + PeerPort => $port, + LocalAddr => $self->{ua}{local_address}, + Proto => 'tcp', + Timeout => $timeout); + die "Can't connect to $host:$port" unless $socket; + my $sel = IO::Select->new($socket); + + { + die "write timeout" if $timeout && !$sel->can_write($timeout); + my $n = syswrite($socket, $requestLine, length($requestLine)); + die $! unless defined($n); + die "short write" if $n != length($requestLine); + } + + my $user_arg = $arg; + + # must handle menus in a special way since they are to be + # converted to HTML. Undefing $arg ensures that the user does + # not see the data before we get a change to convert it. + $arg = undef if $gophertype eq '1' || $gophertype eq '7'; + + # collect response + my $buf = ''; + $response = $self->collect($arg, $response, sub { + die "read timeout" if $timeout && !$sel->can_read($timeout); + my $n = sysread($socket, $buf, $size); + die $! unless defined($n); + return \$buf; + } ); + + # Convert menu to HTML and return data to user. + if ($gophertype eq '1' || $gophertype eq '7') { + my $content = menu2html($response->content); + if (defined $user_arg) { + $response = $self->collect_once($user_arg, $response, $content); + } + else { + $response->content($content); + } + } + + $response; +} + + +sub gopher2url +{ + my($gophertype, $path, $host, $port) = @_; + + my $url; + + if ($gophertype eq '8' || $gophertype eq 'T') { + # telnet session + $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:'); + $url->user($path) if defined $path; + } + else { + $path = URI::Escape::uri_escape($path); + $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path"); + } + $url->host($host); + $url->port($port); + $url; +} + +sub menu2html { + my($menu) = @_; + + $menu =~ s/\015//g; # remove carriage return + my $tmp = <<"EOT"; +<HTML> +<HEAD> + <TITLE>Gopher menu</TITLE> +</HEAD> +<BODY> +<H1>Gopher menu</H1> +EOT + for (split("\n", $menu)) { + last if /^\./; + my($pretty, $path, $host, $port) = split("\t"); + + $pretty =~ s/^(.)//; + my $type = $1; + + my $url = gopher2url($type, $path, $host, $port)->as_string; + $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n}; + } + $tmp .= "</BODY>\n</HTML>\n"; + $tmp; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm new file mode 100644 index 00000000000..59c9eded1ab --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/http.pm @@ -0,0 +1,475 @@ +package LWP::Protocol::http; + +use strict; + +require HTTP::Response; +require HTTP::Status; +require Net::HTTP; + +use vars qw(@ISA @EXTRA_SOCK_OPTS); + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +my $CRLF = "\015\012"; + +sub _new_socket +{ + my($self, $host, $port, $timeout) = @_; + my $conn_cache = $self->{ua}{conn_cache}; + if ($conn_cache) { + if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) { + return $sock if $sock && !$sock->can_read(0); + # if the socket is readable, then either the peer has closed the + # connection or there are some garbage bytes on it. In either + # case we abandon it. + $sock->close; + } + } + + local($^W) = 0; # IO::Socket::INET can be noisy + my $sock = $self->socket_class->new(PeerAddr => $host, + PeerPort => $port, + LocalAddr => $self->{ua}{local_address}, + Proto => 'tcp', + Timeout => $timeout, + KeepAlive => !!$conn_cache, + SendTE => 1, + $self->_extra_sock_opts($host, $port), + ); + + unless ($sock) { + # IO::Socket::INET leaves additional error messages in $@ + $@ =~ s/^.*?: //; + die "Can't connect to $host:$port ($@)"; + } + + # perl 5.005's IO::Socket does not have the blocking method. + eval { $sock->blocking(0); }; + + $sock; +} + +sub socket_type +{ + return "http"; +} + +sub socket_class +{ + my $self = shift; + (ref($self) || $self) . "::Socket"; +} + +sub _extra_sock_opts # to be overridden by subclass +{ + return @EXTRA_SOCK_OPTS; +} + +sub _check_sock +{ + #my($self, $req, $sock) = @_; +} + +sub _get_sock_info +{ + my($self, $res, $sock) = @_; + if (defined(my $peerhost = $sock->peerhost)) { + $res->header("Client-Peer" => "$peerhost:" . $sock->peerport); + } +} + +sub _fixup_header +{ + my($self, $h, $url, $proxy) = @_; + + # Extract 'Host' header + my $hhost = $url->authority; + if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@" + # add authorization header if we need them. HTTP URLs do + # not really support specification of user and password, but + # we allow it. + if (defined($1) && not $h->header('Authorization')) { + require URI::Escape; + $h->authorization_basic(map URI::Escape::uri_unescape($_), + split(":", $1, 2)); + } + } + $h->init_header('Host' => $hhost); + + if ($proxy) { + # Check the proxy URI's userinfo() for proxy credentials + # export http_proxy="http://proxyuser:proxypass@proxyhost:port" + my $p_auth = $proxy->userinfo(); + if(defined $p_auth) { + require URI::Escape; + $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_), + split(":", $p_auth, 2)) + } + } +} + +sub hlist_remove { + my($hlist, $k) = @_; + $k = lc $k; + for (my $i = @$hlist - 2; $i >= 0; $i -= 2) { + next unless lc($hlist->[$i]) eq $k; + splice(@$hlist, $i, 2); + } +} + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size ||= 4096; + + # check method + my $method = $request->method; + unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token + return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'http:' URLs"); + } + + my $url = $request->uri; + my($host, $port, $fullpath); + + # Check if we're proxy'ing + if (defined $proxy) { + # $proxy is an URL to an HTTP server which will proxy this request + $host = $proxy->host; + $port = $proxy->port; + $fullpath = $method eq "CONNECT" ? + ($url->host . ":" . $url->port) : + $url->as_string; + } + else { + $host = $url->host; + $port = $url->port; + $fullpath = $url->path_query; + $fullpath = "/$fullpath" unless $fullpath =~ m,^/,; + } + + # connect to remote site + my $socket = $self->_new_socket($host, $port, $timeout); + $self->_check_sock($request, $socket); + + my @h; + my $request_headers = $request->headers->clone; + $self->_fixup_header($request_headers, $url, $proxy); + + $request_headers->scan(sub { + my($k, $v) = @_; + $k =~ s/^://; + $v =~ s/\n/ /g; + push(@h, $k, $v); + }); + + my $content_ref = $request->content_ref; + $content_ref = $$content_ref if ref($$content_ref); + my $chunked; + my $has_content; + + if (ref($content_ref) eq 'CODE') { + my $clen = $request_headers->header('Content-Length'); + $has_content++ if $clen; + unless (defined $clen) { + push(@h, "Transfer-Encoding" => "chunked"); + $has_content++; + $chunked++; + } + } + else { + # Set (or override) Content-Length header + my $clen = $request_headers->header('Content-Length'); + if (defined($$content_ref) && length($$content_ref)) { + $has_content = length($$content_ref); + if (!defined($clen) || $clen ne $has_content) { + if (defined $clen) { + warn "Content-Length header value was wrong, fixed"; + hlist_remove(\@h, 'Content-Length'); + } + push(@h, 'Content-Length' => $has_content); + } + } + elsif ($clen) { + warn "Content-Length set when there is no content, fixed"; + hlist_remove(\@h, 'Content-Length'); + } + } + + my $write_wait = 0; + $write_wait = 2 + if ($request_headers->header("Expect") || "") =~ /100-continue/; + + my $req_buf = $socket->format_request($method, $fullpath, @h); + #print "------\n$req_buf\n------\n"; + + if (!$has_content || $write_wait || $has_content > 8*1024) { + WRITE: + { + # Since this just writes out the header block it should almost + # always succeed to send the whole buffer in a single write call. + my $n = $socket->syswrite($req_buf, length($req_buf)); + unless (defined $n) { + redo WRITE if $!{EINTR}; + if ($!{EAGAIN}) { + select(undef, undef, undef, 0.1); + redo WRITE; + } + die "write failed: $!"; + } + if ($n) { + substr($req_buf, 0, $n, ""); + } + else { + select(undef, undef, undef, 0.5); + } + redo WRITE if length $req_buf; + } + } + + my($code, $mess, @junk); + my $drop_connection; + + if ($has_content) { + my $eof; + my $wbuf; + my $woffset = 0; + if (ref($content_ref) eq 'CODE') { + my $buf = &$content_ref(); + $buf = "" unless defined($buf); + $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF + if $chunked; + substr($buf, 0, 0) = $req_buf if $req_buf; + $wbuf = \$buf; + } + else { + if ($req_buf) { + my $buf = $req_buf . $$content_ref; + $wbuf = \$buf; + } + else { + $wbuf = $content_ref; + } + $eof = 1; + } + + my $fbits = ''; + vec($fbits, fileno($socket), 1) = 1; + + WRITE: + while ($woffset < length($$wbuf)) { + + my $sel_timeout = $timeout; + if ($write_wait) { + $sel_timeout = $write_wait if $write_wait < $sel_timeout; + } + my $time_before; + $time_before = time if $sel_timeout; + + my $rbits = $fbits; + my $wbits = $write_wait ? undef : $fbits; + my $sel_timeout_before = $sel_timeout; + SELECT: + { + my $nfound = select($rbits, $wbits, undef, $sel_timeout); + if ($nfound < 0) { + if ($!{EINTR} || $!{EAGAIN}) { + if ($time_before) { + $sel_timeout = $sel_timeout_before - (time - $time_before); + $sel_timeout = 0 if $sel_timeout < 0; + } + redo SELECT; + } + die "select failed: $!"; + } + } + + if ($write_wait) { + $write_wait -= time - $time_before; + $write_wait = 0 if $write_wait < 0; + } + + if (defined($rbits) && $rbits =~ /[^\0]/) { + # readable + my $buf = $socket->_rbuf; + my $n = $socket->sysread($buf, 1024, length($buf)); + unless (defined $n) { + die "read failed: $!" unless $!{EINTR} || $!{EAGAIN}; + # if we get here the rest of the block will do nothing + # and we will retry the read on the next round + } + elsif ($n == 0) { + # the server closed the connection before we finished + # writing all the request content. No need to write any more. + $drop_connection++; + last WRITE; + } + $socket->_rbuf($buf); + if (!$code && $buf =~ /\015?\012\015?\012/) { + # a whole response header is present, so we can read it without blocking + ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, + junk_out => \@junk, + ); + if ($code eq "100") { + $write_wait = 0; + undef($code); + } + else { + $drop_connection++; + last WRITE; + # XXX should perhaps try to abort write in a nice way too + } + } + } + if (defined($wbits) && $wbits =~ /[^\0]/) { + my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset); + unless (defined $n) { + die "write failed: $!" unless $!{EINTR} || $!{EAGAIN}; + $n = 0; # will retry write on the next round + } + elsif ($n == 0) { + die "write failed: no bytes written"; + } + $woffset += $n; + + if (!$eof && $woffset >= length($$wbuf)) { + # need to refill buffer from $content_ref code + my $buf = &$content_ref(); + $buf = "" unless defined($buf); + $eof++ unless length($buf); + $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF + if $chunked; + $wbuf = \$buf; + $woffset = 0; + } + } + } # WRITE + } + + ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk) + unless $code; + ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk) + if $code eq "100"; + + my $response = HTTP::Response->new($code, $mess); + my $peer_http_version = $socket->peer_http_version; + $response->protocol("HTTP/$peer_http_version"); + { + local $HTTP::Headers::TRANSLATE_UNDERSCORE; + $response->push_header(@h); + } + $response->push_header("Client-Junk" => \@junk) if @junk; + + $response->request($request); + $self->_get_sock_info($response, $socket); + + if ($method eq "CONNECT") { + $response->{client_socket} = $socket; # so it can be picked up + return $response; + } + + if (my @te = $response->remove_header('Transfer-Encoding')) { + $response->push_header('Client-Transfer-Encoding', \@te); + } + $response->push_header('Client-Response-Num', scalar $socket->increment_response_count); + + my $complete; + $response = $self->collect($arg, $response, sub { + my $buf = ""; #prevent use of uninitialized value in SSLeay.xs + my $n; + READ: + { + $n = $socket->read_entity_body($buf, $size); + unless (defined $n) { + redo READ if $!{EINTR} || $!{EAGAIN}; + die "read failed: $!"; + } + redo READ if $n == -1; + } + $complete++ if !$n; + return \$buf; + } ); + $drop_connection++ unless $complete; + + @h = $socket->get_trailers; + if (@h) { + local $HTTP::Headers::TRANSLATE_UNDERSCORE; + $response->push_header(@h); + } + + # keep-alive support + unless ($drop_connection) { + if (my $conn_cache = $self->{ua}{conn_cache}) { + my %connection = map { (lc($_) => 1) } + split(/\s*,\s*/, ($response->header("Connection") || "")); + if (($peer_http_version eq "1.1" && !$connection{close}) || + $connection{"keep-alive"}) + { + $conn_cache->deposit($self->socket_type, "$host:$port", $socket); + } + } + } + + $response; +} + + +#----------------------------------------------------------- +package LWP::Protocol::http::SocketMethods; + +sub sysread { + my $self = shift; + if (my $timeout = ${*$self}{io_socket_timeout}) { + die "read timeout" unless $self->can_read($timeout); + } + else { + # since we have made the socket non-blocking we + # use select to wait for some data to arrive + $self->can_read(undef) || die "Assert"; + } + sysread($self, $_[0], $_[1], $_[2] || 0); +} + +sub can_read { + my($self, $timeout) = @_; + my $fbits = ''; + vec($fbits, fileno($self), 1) = 1; + SELECT: + { + my $before; + $before = time if $timeout; + my $nfound = select($fbits, undef, undef, $timeout); + if ($nfound < 0) { + if ($!{EINTR} || $!{EAGAIN}) { + # don't really think EAGAIN can happen here + if ($timeout) { + $timeout -= time - $before; + $timeout = 0 if $timeout < 0; + } + redo SELECT; + } + die "select failed: $!"; + } + return $nfound > 0; + } +} + +sub ping { + my $self = shift; + !$self->can_read(0); +} + +sub increment_response_count { + my $self = shift; + return ++${*$self}{'myhttp_response_count'}; +} + +#----------------------------------------------------------- +package LWP::Protocol::http::Socket; +use vars qw(@ISA); +@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP); + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm new file mode 100644 index 00000000000..08ce9cf15af --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm @@ -0,0 +1,289 @@ +package LWP::Protocol::http10; + +use strict; + +require HTTP::Response; +require HTTP::Status; +require IO::Socket; +require IO::Select; + +use vars qw(@ISA @EXTRA_SOCK_OPTS); + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +my $CRLF = "\015\012"; # how lines should be terminated; + # "\r\n" is not correct on all systems, for + # instance MacPerl defines it to "\012\015" + +sub _new_socket +{ + my($self, $host, $port, $timeout) = @_; + + local($^W) = 0; # IO::Socket::INET can be noisy + my $sock = IO::Socket::INET->new(PeerAddr => $host, + PeerPort => $port, + Proto => 'tcp', + Timeout => $timeout, + $self->_extra_sock_opts($host, $port), + ); + unless ($sock) { + # IO::Socket::INET leaves additional error messages in $@ + $@ =~ s/^.*?: //; + die "Can't connect to $host:$port ($@)"; + } + $sock; +} + +sub _extra_sock_opts # to be overridden by subclass +{ + return @EXTRA_SOCK_OPTS; +} + + +sub _check_sock +{ + #my($self, $req, $sock) = @_; +} + +sub _get_sock_info +{ + my($self, $res, $sock) = @_; + if (defined(my $peerhost = $sock->peerhost)) { + $res->header("Client-Peer" => "$peerhost:" . $sock->peerport); + } +} + +sub _fixup_header +{ + my($self, $h, $url, $proxy) = @_; + + $h->remove_header('Connection'); # need support here to be useful + + # HTTP/1.1 will require us to send the 'Host' header, so we might + # as well start now. + my $hhost = $url->authority; + if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@" + # add authorization header if we need them. HTTP URLs do + # not really support specification of user and password, but + # we allow it. + if (defined($1) && not $h->header('Authorization')) { + require URI::Escape; + $h->authorization_basic(map URI::Escape::uri_unescape($_), + split(":", $1, 2)); + } + } + $h->init_header('Host' => $hhost); + + if ($proxy) { + # Check the proxy URI's userinfo() for proxy credentials + # export http_proxy="http://proxyuser:proxypass@proxyhost:port" + my $p_auth = $proxy->userinfo(); + if(defined $p_auth) { + require URI::Escape; + $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_), + split(":", $p_auth, 2)) + } + } +} + + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size ||= 4096; + + # check method + my $method = $request->method; + unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token + return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'http:' URLs"); + } + + my $url = $request->uri; + my($host, $port, $fullpath); + + # Check if we're proxy'ing + if (defined $proxy) { + # $proxy is an URL to an HTTP server which will proxy this request + $host = $proxy->host; + $port = $proxy->port; + $fullpath = $method eq "CONNECT" ? + ($url->host . ":" . $url->port) : + $url->as_string; + } + else { + $host = $url->host; + $port = $url->port; + $fullpath = $url->path_query; + $fullpath = "/" unless length $fullpath; + } + + # connect to remote site + my $socket = $self->_new_socket($host, $port, $timeout); + $self->_check_sock($request, $socket); + + my $sel = IO::Select->new($socket) if $timeout; + + my $request_line = "$method $fullpath HTTP/1.0$CRLF"; + + my $h = $request->headers->clone; + my $cont_ref = $request->content_ref; + $cont_ref = $$cont_ref if ref($$cont_ref); + my $ctype = ref($cont_ref); + + # If we're sending content we *have* to specify a content length + # otherwise the server won't know a messagebody is coming. + if ($ctype eq 'CODE') { + die 'No Content-Length header for request with dynamic content' + unless defined($h->header('Content-Length')) || + $h->content_type =~ /^multipart\//; + # For HTTP/1.1 we could have used chunked transfer encoding... + } + else { + $h->header('Content-Length' => length $$cont_ref) + if defined($$cont_ref) && length($$cont_ref); + } + + $self->_fixup_header($h, $url, $proxy); + + my $buf = $request_line . $h->as_string($CRLF) . $CRLF; + my $n; # used for return value from syswrite/sysread + my $length; + my $offset; + + # syswrite $buf + $length = length($buf); + $offset = 0; + while ( $offset < $length ) { + die "write timeout" if $timeout && !$sel->can_write($timeout); + $n = $socket->syswrite($buf, $length-$offset, $offset ); + die $! unless defined($n); + $offset += $n; + } + + if ($ctype eq 'CODE') { + while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) { + # syswrite $buf + $length = length($buf); + $offset = 0; + while ( $offset < $length ) { + die "write timeout" if $timeout && !$sel->can_write($timeout); + $n = $socket->syswrite($buf, $length-$offset, $offset ); + die $! unless defined($n); + $offset += $n; + } + } + } + elsif (defined($$cont_ref) && length($$cont_ref)) { + # syswrite $$cont_ref + $length = length($$cont_ref); + $offset = 0; + while ( $offset < $length ) { + die "write timeout" if $timeout && !$sel->can_write($timeout); + $n = $socket->syswrite($$cont_ref, $length-$offset, $offset ); + die $! unless defined($n); + $offset += $n; + } + } + + # read response line from server + my $response; + $buf = ''; + + # Inside this loop we will read the response line and all headers + # found in the response. + while (1) { + die "read timeout" if $timeout && !$sel->can_read($timeout); + $n = $socket->sysread($buf, $size, length($buf)); + die $! unless defined($n); + die "unexpected EOF before status line seen" unless $n; + + if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) { + # HTTP/1.0 response or better + my($ver,$code,$msg) = ($1, $2, $3); + $msg =~ s/\015$//; + $response = HTTP::Response->new($code, $msg); + $response->protocol($ver); + + # ensure that we have read all headers. The headers will be + # terminated by two blank lines + until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) { + # must read more if we can... + die "read timeout" if $timeout && !$sel->can_read($timeout); + my $old_len = length($buf); + $n = $socket->sysread($buf, $size, $old_len); + die $! unless defined($n); + die "unexpected EOF before all headers seen" unless $n; + } + + # now we start parsing the headers. The strategy is to + # remove one line at a time from the beginning of the header + # buffer ($res). + my($key, $val); + while ($buf =~ s/([^\012]*)\012//) { + my $line = $1; + + # if we need to restore as content when illegal headers + # are found. + my $save = "$line\012"; + + $line =~ s/\015$//; + last unless length $line; + + if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) { + $response->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } + elsif ($line =~ /^\s+(.*)/ && $key) { + $val .= " $1"; + } + else { + $response->push_header("Client-Bad-Header-Line" => $line); + } + } + $response->push_header($key, $val) if $key; + last; + + } + elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or + $buf =~ /\012/ ) { + # HTTP/0.9 or worse + $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK"); + $response->protocol('HTTP/0.9'); + last; + + } + else { + # need more data + } + }; + $response->request($request); + $self->_get_sock_info($response, $socket); + + if ($method eq "CONNECT") { + $response->{client_socket} = $socket; # so it can be picked up + $response->content($buf); # in case we read more than the headers + return $response; + } + + my $usebuf = length($buf) > 0; + $response = $self->collect($arg, $response, sub { + if ($usebuf) { + $usebuf = 0; + return \$buf; + } + die "read timeout" if $timeout && !$sel->can_read($timeout); + my $n = $socket->sysread($buf, $size); + die $! unless defined($n); + return \$buf; + } ); + + #$socket->close; + + $response; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm new file mode 100644 index 00000000000..367c8f793d8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm @@ -0,0 +1,51 @@ +package LWP::Protocol::https; + +use strict; + +use vars qw(@ISA); +require LWP::Protocol::http; +@ISA = qw(LWP::Protocol::http); + +sub socket_type +{ + return "https"; +} + +sub _check_sock +{ + my($self, $req, $sock) = @_; + my $check = $req->header("If-SSL-Cert-Subject"); + if (defined $check) { + my $cert = $sock->get_peer_certificate || + die "Missing SSL certificate"; + my $subject = $cert->subject_name; + die "Bad SSL certificate subject: '$subject' !~ /$check/" + unless $subject =~ /$check/; + $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on + } +} + +sub _get_sock_info +{ + my $self = shift; + $self->SUPER::_get_sock_info(@_); + my($res, $sock) = @_; + $res->header("Client-SSL-Cipher" => $sock->get_cipher); + my $cert = $sock->get_peer_certificate; + if ($cert) { + $res->header("Client-SSL-Cert-Subject" => $cert->subject_name); + $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name); + } + if(! eval { $sock->get_peer_verify }) { + $res->header("Client-SSL-Warning" => "Peer certificate not verified"); + } +} + +#----------------------------------------------------------- +package LWP::Protocol::https::Socket; + +use vars qw(@ISA); +require Net::HTTPS; +@ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods); + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/https10.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/https10.pm new file mode 100644 index 00000000000..662ba76d284 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/https10.pm @@ -0,0 +1,75 @@ +package LWP::Protocol::https10; + +use strict; + +# Figure out which SSL implementation to use +use vars qw($SSL_CLASS); +if ($Net::SSL::VERSION) { + $SSL_CLASS = "Net::SSL"; +} +elsif ($IO::Socket::SSL::VERSION) { + $SSL_CLASS = "IO::Socket::SSL"; # it was already loaded +} +else { + eval { require Net::SSL; }; # from Crypt-SSLeay + if ($@) { + require IO::Socket::SSL; + $SSL_CLASS = "IO::Socket::SSL"; + } + else { + $SSL_CLASS = "Net::SSL"; + } +} + + +use vars qw(@ISA); + +require LWP::Protocol::http10; +@ISA=qw(LWP::Protocol::http10); + +sub _new_socket +{ + my($self, $host, $port, $timeout) = @_; + local($^W) = 0; # IO::Socket::INET can be noisy + my $sock = $SSL_CLASS->new(PeerAddr => $host, + PeerPort => $port, + Proto => 'tcp', + Timeout => $timeout, + ); + unless ($sock) { + # IO::Socket::INET leaves additional error messages in $@ + $@ =~ s/^.*?: //; + die "Can't connect to $host:$port ($@)"; + } + $sock; +} + +sub _check_sock +{ + my($self, $req, $sock) = @_; + my $check = $req->header("If-SSL-Cert-Subject"); + if (defined $check) { + my $cert = $sock->get_peer_certificate || + die "Missing SSL certificate"; + my $subject = $cert->subject_name; + die "Bad SSL certificate subject: '$subject' !~ /$check/" + unless $subject =~ /$check/; + $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on + } +} + +sub _get_sock_info +{ + my $self = shift; + $self->SUPER::_get_sock_info(@_); + my($res, $sock) = @_; + $res->header("Client-SSL-Cipher" => $sock->get_cipher); + my $cert = $sock->get_peer_certificate; + if ($cert) { + $res->header("Client-SSL-Cert-Subject" => $cert->subject_name); + $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name); + } + $res->header("Client-SSL-Warning" => "Peer certificate not verified"); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/loopback.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/loopback.pm new file mode 100644 index 00000000000..2cd67ae3608 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/loopback.pm @@ -0,0 +1,26 @@ +package LWP::Protocol::loopback; + +use strict; +use vars qw(@ISA); +require HTTP::Response; + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +sub request { + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + my $response = HTTP::Response->new(200, "OK"); + $response->content_type("message/http; msgtype=request"); + + $response->header("Via", "loopback/1.0 $proxy") + if $proxy; + + $response->header("X-Arg", $arg); + $response->header("X-Read-Size", $size); + $response->header("X-Timeout", $timeout); + + return $self->collect_once($arg, $response, $request->as_string); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm new file mode 100644 index 00000000000..46db7162e44 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm @@ -0,0 +1,183 @@ +package LWP::Protocol::mailto; + +# This module implements the mailto protocol. It is just a simple +# frontend to the Unix sendmail program except on MacOS, where it uses +# Mail::Internet. + +require LWP::Protocol; +require HTTP::Request; +require HTTP::Response; +require HTTP::Status; + +use Carp; +use strict; +use vars qw(@ISA $SENDMAIL); + +@ISA = qw(LWP::Protocol); + +unless ($SENDMAIL = $ENV{SENDMAIL}) { + for my $sm (qw(/usr/sbin/sendmail + /usr/lib/sendmail + /usr/ucblib/sendmail + )) + { + if (-x $sm) { + $SENDMAIL = $sm; + last; + } + } + die "Can't find the 'sendmail' program" unless $SENDMAIL; +} + +sub request +{ + my($self, $request, $proxy, $arg, $size) = @_; + + my ($mail, $addr) if $^O eq "MacOS"; + my @text = () if $^O eq "MacOS"; + + # check proxy + if (defined $proxy) + { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy with mail'); + } + + # check method + my $method = $request->method; + + if ($method ne 'POST') { + return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'mailto:' URLs"); + } + + # check url + my $url = $request->uri; + + my $scheme = $url->scheme; + if ($scheme ne 'mailto') { + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::mailto::request called for '$scheme'"); + } + if ($^O eq "MacOS") { + eval { + require Mail::Internet; + }; + if($@) { + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have MailTools installed"); + } + unless ($ENV{SMTPHOSTS}) { + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have SMTPHOSTS defined"); + } + } + else { + unless (-x $SENDMAIL) { + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have $SENDMAIL"); + } + } + if ($^O eq "MacOS") { + $mail = Mail::Internet->new or + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Can't get a Mail::Internet object"); + } + else { + open(SENDMAIL, "| $SENDMAIL -oi -t") or + return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Can't run $SENDMAIL: $!"); + } + if ($^O eq "MacOS") { + $addr = $url->encoded822addr; + } + else { + $request = $request->clone; # we modify a copy + my @h = $url->headers; # URL headers override those in the request + while (@h) { + my $k = shift @h; + my $v = shift @h; + next unless defined $v; + if (lc($k) eq "body") { + $request->content($v); + } + else { + $request->push_header($k => $v); + } + } + } + if ($^O eq "MacOS") { + $mail->add(To => $addr); + $mail->add(split(/[:\n]/,$request->headers_as_string)); + } + else { + print SENDMAIL $request->headers_as_string; + print SENDMAIL "\n"; + } + my $content = $request->content; + if (defined $content) { + my $contRef = ref($content) ? $content : \$content; + if (ref($contRef) eq 'SCALAR') { + if ($^O eq "MacOS") { + @text = split("\n",$$contRef); + foreach (@text) { + $_ .= "\n"; + } + } + else { + print SENDMAIL $$contRef; + } + + } + elsif (ref($contRef) eq 'CODE') { + # Callback provides data + my $d; + if ($^O eq "MacOS") { + my $stuff = ""; + while (length($d = &$contRef)) { + $stuff .= $d; + } + @text = split("\n",$stuff); + foreach (@text) { + $_ .= "\n"; + } + } + else { + print SENDMAIL $d; + } + } + } + if ($^O eq "MacOS") { + $mail->body(\@text); + unless ($mail->smtpsend) { + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Mail::Internet->smtpsend unable to send message to <$addr>"); + } + } + else { + unless (close(SENDMAIL)) { + my $err = $! ? "$!" : "Exit status $?"; + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "$SENDMAIL: $err"); + } + } + + + my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED, + "Mail accepted"); + $response->header('Content-Type', 'text/plain'); + if ($^O eq "MacOS") { + $response->header('Server' => "Mail::Internet $Mail::Internet::VERSION"); + $response->content("Message sent to <$addr>\n"); + } + else { + $response->header('Server' => $SENDMAIL); + my $to = $request->header("To"); + $response->content("Message sent to <$to>\n"); + } + + return $response; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/nntp.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/nntp.pm new file mode 100644 index 00000000000..788477d488a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/nntp.pm @@ -0,0 +1,145 @@ +package LWP::Protocol::nntp; + +# Implementation of the Network News Transfer Protocol (RFC 977) + +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +require HTTP::Response; +require HTTP::Status; +require Net::NNTP; + +use strict; + + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size = 4096 unless $size; + + # Check for proxy + if (defined $proxy) { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through NNTP'); + } + + # Check that the scheme is as expected + my $url = $request->uri; + my $scheme = $url->scheme; + unless ($scheme eq 'news' || $scheme eq 'nntp') { + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::nntp::request called for '$scheme'"); + } + + # check for a valid method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for '$scheme:' URLs"); + } + + # extract the identifier and check against posting to an article + my $groupart = $url->_group; + my $is_art = $groupart =~ /@/; + + if ($is_art && $method eq 'POST') { + return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + "Can't post to an article <$groupart>"); + } + + my $nntp = Net::NNTP->new($url->host, + #Port => 18574, + Timeout => $timeout, + #Debug => 1, + ); + die "Can't connect to nntp server" unless $nntp; + + # Check the initial welcome message from the NNTP server + if ($nntp->status != 2) { + return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE, + $nntp->message); + } + my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK"); + + my $mess = $nntp->message; + + # Try to extract server name from greeting message. + # Don't know if this works well for a large class of servers, but + # this works for our server. + $mess =~ s/\s+ready\b.*//; + $mess =~ s/^\S+\s+//; + $response->header(Server => $mess); + + # First we handle posting of articles + if ($method eq 'POST') { + $nntp->quit; $nntp = undef; + $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED); + $response->message("POST not implemented yet"); + return $response; + } + + # The method must be "GET" or "HEAD" by now + if (!$is_art) { + if (!$nntp->group($groupart)) { + $response->code(&HTTP::Status::RC_NOT_FOUND); + $response->message($nntp->message); + } + $nntp->quit; $nntp = undef; + # HEAD: just check if the group exists + if ($method eq 'GET' && $response->is_success) { + $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED); + $response->message("GET newsgroup not implemented yet"); + } + return $response; + } + + # Send command to server to retrieve an article (or just the headers) + my $get = $method eq 'HEAD' ? "head" : "article"; + my $art = $nntp->$get("<$groupart>"); + unless ($art) { + $nntp->quit; $nntp = undef; + $response->code(&HTTP::Status::RC_NOT_FOUND); + $response->message($nntp->message); + return $response; + } + + # Parse headers + my($key, $val); + local $_; + while ($_ = shift @$art) { + if (/^\s+$/) { + last; # end of headers + } + elsif (/^(\S+):\s*(.*)/) { + $response->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } + elsif (/^\s+(.*)/) { + next unless $key; + $val .= $1; + } + else { + unshift(@$art, $_); + last; + } + } + $response->push_header($key, $val) if $key; + + # Ensure that there is a Content-Type header + $response->header("Content-Type", "text/plain") + unless $response->header("Content-Type"); + + # Collect the body + $response = $self->collect_once($arg, $response, join("", @$art)) + if @$art; + + # Say goodbye to the server + $nntp->quit; + $nntp = undef; + + $response; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/nogo.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/nogo.pm new file mode 100644 index 00000000000..68150a722d5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/nogo.pm @@ -0,0 +1,24 @@ +package LWP::Protocol::nogo; +# If you want to disable access to a particular scheme, use this +# class and then call +# LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo'); +# For then on, attempts to access URLs with that scheme will generate +# a 500 error. + +use strict; +use vars qw(@ISA); +require HTTP::Response; +require HTTP::Status; +require LWP::Protocol; +@ISA = qw(LWP::Protocol); + +sub request { + my($self, $request) = @_; + my $scheme = $request->uri->scheme; + + return HTTP::Response->new( + &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Access to \'$scheme\' URIs has been disabled" + ); +} +1; diff --git a/Master/tlpkg/tlperl/lib/LWP/RobotUA.pm b/Master/tlpkg/tlperl/lib/LWP/RobotUA.pm new file mode 100644 index 00000000000..82c99fe26c9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/RobotUA.pm @@ -0,0 +1,308 @@ +package LWP::RobotUA; + +require LWP::UserAgent; +@ISA = qw(LWP::UserAgent); +$VERSION = "5.835"; + +require WWW::RobotRules; +require HTTP::Request; +require HTTP::Response; + +use Carp (); +use HTTP::Status (); +use HTTP::Date qw(time2str); +use strict; + + +# +# Additional attributes in addition to those found in LWP::UserAgent: +# +# $self->{'delay'} Required delay between request to the same +# server in minutes. +# +# $self->{'rules'} A WWW::RobotRules object +# + +sub new +{ + my $class = shift; + my %cnf; + if (@_ < 4) { + # legacy args + @cnf{qw(agent from rules)} = @_; + } + else { + %cnf = @_; + } + + Carp::croak('LWP::RobotUA agent required') unless $cnf{agent}; + Carp::croak('LWP::RobotUA from address required') + unless $cnf{from} && $cnf{from} =~ m/\@/; + + my $delay = delete $cnf{delay} || 1; + my $use_sleep = delete $cnf{use_sleep}; + $use_sleep = 1 unless defined($use_sleep); + my $rules = delete $cnf{rules}; + + my $self = LWP::UserAgent->new(%cnf); + $self = bless $self, $class; + + $self->{'delay'} = $delay; # minutes + $self->{'use_sleep'} = $use_sleep; + + if ($rules) { + $rules->agent($cnf{agent}); + $self->{'rules'} = $rules; + } + else { + $self->{'rules'} = WWW::RobotRules->new($cnf{agent}); + } + + $self; +} + + +sub delay { shift->_elem('delay', @_); } +sub use_sleep { shift->_elem('use_sleep', @_); } + + +sub agent +{ + my $self = shift; + my $old = $self->SUPER::agent(@_); + if (@_) { + # Changing our name means to start fresh + $self->{'rules'}->agent($self->{'agent'}); + } + $old; +} + + +sub rules { + my $self = shift; + my $old = $self->_elem('rules', @_); + $self->{'rules'}->agent($self->{'agent'}) if @_; + $old; +} + + +sub no_visits +{ + my($self, $netloc) = @_; + $self->{'rules'}->no_visits($netloc) || 0; +} + +*host_count = \&no_visits; # backwards compatibility with LWP-5.02 + + +sub host_wait +{ + my($self, $netloc) = @_; + return undef unless defined $netloc; + my $last = $self->{'rules'}->last_visit($netloc); + if ($last) { + my $wait = int($self->{'delay'} * 60 - (time - $last)); + $wait = 0 if $wait < 0; + return $wait; + } + return 0; +} + + +sub simple_request +{ + my($self, $request, $arg, $size) = @_; + + # Do we try to access a new server? + my $allowed = $self->{'rules'}->allowed($request->uri); + + if ($allowed < 0) { + # Host is not visited before, or robots.txt expired; fetch "robots.txt" + my $robot_url = $request->uri->clone; + $robot_url->path("robots.txt"); + $robot_url->query(undef); + + # make access to robot.txt legal since this will be a recursive call + $self->{'rules'}->parse($robot_url, ""); + + my $robot_req = HTTP::Request->new('GET', $robot_url); + my $robot_res = $self->request($robot_req); + my $fresh_until = $robot_res->fresh_until; + if ($robot_res->is_success) { + my $c = $robot_res->content; + if ($robot_res->content_type =~ m,^text/, && $c =~ /^\s*Disallow\s*:/mi) { + $self->{'rules'}->parse($robot_url, $c, $fresh_until); + } + else { + $self->{'rules'}->parse($robot_url, "", $fresh_until); + } + + } + else { + $self->{'rules'}->parse($robot_url, "", $fresh_until); + } + + # recalculate allowed... + $allowed = $self->{'rules'}->allowed($request->uri); + } + + # Check rules + unless ($allowed) { + my $res = HTTP::Response->new( + &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt'); + $res->request( $request ); # bind it to that request + return $res; + } + + my $netloc = eval { local $SIG{__DIE__}; $request->uri->host_port; }; + my $wait = $self->host_wait($netloc); + + if ($wait) { + if ($self->{'use_sleep'}) { + sleep($wait) + } + else { + my $res = HTTP::Response->new( + &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down'); + $res->header('Retry-After', time2str(time + $wait)); + $res->request( $request ); # bind it to that request + return $res; + } + } + + # Perform the request + my $res = $self->SUPER::simple_request($request, $arg, $size); + + $self->{'rules'}->visit($netloc); + + $res; +} + + +sub as_string +{ + my $self = shift; + my @s; + push(@s, "Robot: $self->{'agent'} operated by $self->{'from'} [$self]"); + push(@s, " Minimum delay: " . int($self->{'delay'}*60) . "s"); + push(@s, " Will sleep if too early") if $self->{'use_sleep'}; + push(@s, " Rules = $self->{'rules'}"); + join("\n", @s, ''); +} + +1; + + +__END__ + +=head1 NAME + +LWP::RobotUA - a class for well-behaved Web robots + +=head1 SYNOPSIS + + use LWP::RobotUA; + my $ua = LWP::RobotUA->new('my-robot/0.1', 'me@foo.com'); + $ua->delay(10); # be very nice -- max one hit every ten minutes! + ... + + # Then just use it just like a normal LWP::UserAgent: + my $response = $ua->get('http://whatever.int/...'); + ... + +=head1 DESCRIPTION + +This class implements a user agent that is suitable for robot +applications. Robots should be nice to the servers they visit. They +should consult the F</robots.txt> file to ensure that they are welcomed +and they should not make requests too frequently. + +But before you consider writing a robot, take a look at +<URL:http://www.robotstxt.org/>. + +When you use a I<LWP::RobotUA> object as your user agent, then you do not +really have to think about these things yourself; C<robots.txt> files +are automatically consulted and obeyed, the server isn't queried +too rapidly, and so on. Just send requests +as you do when you are using a normal I<LWP::UserAgent> +object (using C<< $ua->get(...) >>, C<< $ua->head(...) >>, +C<< $ua->request(...) >>, etc.), and this +special agent will make sure you are nice. + +=head1 METHODS + +The LWP::RobotUA is a sub-class of LWP::UserAgent and implements the +same methods. In addition the following methods are provided: + +=over 4 + +=item $ua = LWP::RobotUA->new( %options ) + +=item $ua = LWP::RobotUA->new( $agent, $from ) + +=item $ua = LWP::RobotUA->new( $agent, $from, $rules ) + +The LWP::UserAgent options C<agent> and C<from> are mandatory. The +options C<delay>, C<use_sleep> and C<rules> initialize attributes +private to the RobotUA. If C<rules> are not provided, then +C<WWW::RobotRules> is instantiated providing an internal database of +F<robots.txt>. + +It is also possible to just pass the value of C<agent>, C<from> and +optionally C<rules> as plain positional arguments. + +=item $ua->delay + +=item $ua->delay( $minutes ) + +Get/set the minimum delay between requests to the same server, in +I<minutes>. The default is 1 minute. Note that this number doesn't +have to be an integer; for example, this sets the delay to 10 seconds: + + $ua->delay(10/60); + +=item $ua->use_sleep + +=item $ua->use_sleep( $boolean ) + +Get/set a value indicating whether the UA should sleep() if requests +arrive too fast, defined as $ua->delay minutes not passed since +last request to the given server. The default is TRUE. If this value is +FALSE then an internal SERVICE_UNAVAILABLE response will be generated. +It will have an Retry-After header that indicates when it is OK to +send another request to this server. + +=item $ua->rules + +=item $ua->rules( $rules ) + +Set/get which I<WWW::RobotRules> object to use. + +=item $ua->no_visits( $netloc ) + +Returns the number of documents fetched from this server host. Yeah I +know, this method should probably have been named num_visits() or +something like that. :-( + +=item $ua->host_wait( $netloc ) + +Returns the number of I<seconds> (from now) you must wait before you can +make a new request to this host. + +=item $ua->as_string + +Returns a string that describes the state of the UA. +Mainly useful for debugging. + +=back + +=head1 SEE ALSO + +L<LWP::UserAgent>, L<WWW::RobotRules> + +=head1 COPYRIGHT + +Copyright 1996-2004 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/LWP/Simple.pm b/Master/tlpkg/tlperl/lib/LWP/Simple.pm new file mode 100644 index 00000000000..05bcdaa1f6d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Simple.pm @@ -0,0 +1,253 @@ +package LWP::Simple; + +use strict; +use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION); + +require Exporter; + +@EXPORT = qw(get head getprint getstore mirror); +@EXPORT_OK = qw($ua); + +# I really hate this. I was a bad idea to do it in the first place. +# Wonder how to get rid of it??? (It even makes LWP::Simple 7% slower +# for trivial tests) +use HTTP::Status; +push(@EXPORT, @HTTP::Status::EXPORT); + +$VERSION = "5.835"; + +sub import +{ + my $pkg = shift; + my $callpkg = caller; + Exporter::export($pkg, $callpkg, @_); +} + +use LWP::UserAgent (); +use HTTP::Status (); +use HTTP::Date (); +$ua = LWP::UserAgent->new; # we create a global UserAgent object +$ua->agent("LWP::Simple/$VERSION "); +$ua->env_proxy; + + +sub get ($) +{ + my $response = $ua->get(shift); + return $response->decoded_content if $response->is_success; + return undef; +} + + +sub head ($) +{ + my($url) = @_; + my $request = HTTP::Request->new(HEAD => $url); + my $response = $ua->request($request); + + if ($response->is_success) { + return $response unless wantarray; + return (scalar $response->header('Content-Type'), + scalar $response->header('Content-Length'), + HTTP::Date::str2time($response->header('Last-Modified')), + HTTP::Date::str2time($response->header('Expires')), + scalar $response->header('Server'), + ); + } + return; +} + + +sub getprint ($) +{ + my($url) = @_; + my $request = HTTP::Request->new(GET => $url); + local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR + my $callback = sub { print $_[0] }; + if ($^O eq "MacOS") { + $callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] } + } + my $response = $ua->request($request, $callback); + unless ($response->is_success) { + print STDERR $response->status_line, " <URL:$url>\n"; + } + $response->code; +} + + +sub getstore ($$) +{ + my($url, $file) = @_; + my $request = HTTP::Request->new(GET => $url); + my $response = $ua->request($request, $file); + + $response->code; +} + + +sub mirror ($$) +{ + my($url, $file) = @_; + my $response = $ua->mirror($url, $file); + $response->code; +} + + +1; + +__END__ + +=head1 NAME + +LWP::Simple - simple procedural interface to LWP + +=head1 SYNOPSIS + + perl -MLWP::Simple -e 'getprint "http://www.sn.no"' + + use LWP::Simple; + $content = get("http://www.sn.no/"); + die "Couldn't get it!" unless defined $content; + + if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) { + ... + } + + if (is_success(getprint("http://www.sn.no/"))) { + ... + } + +=head1 DESCRIPTION + +This module is meant for people who want a simplified view of the +libwww-perl library. It should also be suitable for one-liners. If +you need more control or access to the header fields in the requests +sent and responses received, then you should use the full object-oriented +interface provided by the C<LWP::UserAgent> module. + +The following functions are provided (and exported) by this module: + +=over 3 + +=item get($url) + +The get() function will fetch the document identified by the given URL +and return it. It returns C<undef> if it fails. The $url argument can +be either a string or a reference to a URI object. + +You will not be able to examine the response code or response headers +(like 'Content-Type') when you are accessing the web using this +function. If you need that information you should use the full OO +interface (see L<LWP::UserAgent>). + +=item head($url) + +Get document headers. Returns the following 5 values if successful: +($content_type, $document_length, $modified_time, $expires, $server) + +Returns an empty list if it fails. In scalar context returns TRUE if +successful. + +=item getprint($url) + +Get and print a document identified by a URL. The document is printed +to the selected default filehandle for output (normally STDOUT) as +data is received from the network. If the request fails, then the +status code and message are printed on STDERR. The return value is +the HTTP response code. + +=item getstore($url, $file) + +Gets a document identified by a URL and stores it in the file. The +return value is the HTTP response code. + +=item mirror($url, $file) + +Get and store a document identified by a URL, using +I<If-modified-since>, and checking the I<Content-Length>. Returns +the HTTP response code. + +=back + +This module also exports the HTTP::Status constants and procedures. +You can use them when you check the response code from getprint(), +getstore() or mirror(). The constants are: + + RC_CONTINUE + RC_SWITCHING_PROTOCOLS + RC_OK + RC_CREATED + RC_ACCEPTED + RC_NON_AUTHORITATIVE_INFORMATION + RC_NO_CONTENT + RC_RESET_CONTENT + RC_PARTIAL_CONTENT + RC_MULTIPLE_CHOICES + RC_MOVED_PERMANENTLY + RC_MOVED_TEMPORARILY + RC_SEE_OTHER + RC_NOT_MODIFIED + RC_USE_PROXY + RC_BAD_REQUEST + RC_UNAUTHORIZED + RC_PAYMENT_REQUIRED + RC_FORBIDDEN + RC_NOT_FOUND + RC_METHOD_NOT_ALLOWED + RC_NOT_ACCEPTABLE + RC_PROXY_AUTHENTICATION_REQUIRED + RC_REQUEST_TIMEOUT + RC_CONFLICT + RC_GONE + RC_LENGTH_REQUIRED + RC_PRECONDITION_FAILED + RC_REQUEST_ENTITY_TOO_LARGE + RC_REQUEST_URI_TOO_LARGE + RC_UNSUPPORTED_MEDIA_TYPE + RC_INTERNAL_SERVER_ERROR + RC_NOT_IMPLEMENTED + RC_BAD_GATEWAY + RC_SERVICE_UNAVAILABLE + RC_GATEWAY_TIMEOUT + RC_HTTP_VERSION_NOT_SUPPORTED + +The HTTP::Status classification functions are: + +=over 3 + +=item is_success($rc) + +True if response code indicated a successful request. + +=item is_error($rc) + +True if response code indicated that an error occurred. + +=back + +The module will also export the LWP::UserAgent object as C<$ua> if you +ask for it explicitly. + +The user agent created by this module will identify itself as +"LWP::Simple/#.##" +and will initialize its proxy defaults from the environment (by +calling $ua->env_proxy). + +=head1 CAVEAT + +Note that if you are using both LWP::Simple and the very popular CGI.pm +module, you may be importing a C<head> function from each module, +producing a warning like "Prototype mismatch: sub main::head ($) vs +none". Get around this problem by just not importing LWP::Simple's +C<head> function, like so: + + use LWP::Simple qw(!head); + use CGI qw(:standard); # then only CGI.pm defines a head() + +Then if you do need LWP::Simple's C<head> function, you can just call +it as C<LWP::Simple::head($url)>. + +=head1 SEE ALSO + +L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>, +L<lwp-mirror> diff --git a/Master/tlpkg/tlperl/lib/LWP/UserAgent.pm b/Master/tlpkg/tlperl/lib/LWP/UserAgent.pm new file mode 100644 index 00000000000..d098a449556 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/UserAgent.pm @@ -0,0 +1,1699 @@ +package LWP::UserAgent; + +use strict; +use vars qw(@ISA $VERSION); + +require LWP::MemberMixin; +@ISA = qw(LWP::MemberMixin); +$VERSION = "5.835"; + +use HTTP::Request (); +use HTTP::Response (); +use HTTP::Date (); + +use LWP (); +use LWP::Protocol (); + +use Carp (); + +if ($ENV{PERL_LWP_USE_HTTP_10}) { + require LWP::Protocol::http10; + LWP::Protocol::implementor('http', 'LWP::Protocol::http10'); + eval { + require LWP::Protocol::https10; + LWP::Protocol::implementor('https', 'LWP::Protocol::https10'); + }; +} + + + +sub new +{ + # Check for common user mistake + Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference") + if ref($_[1]) eq 'HASH'; + + my($class, %cnf) = @_; + + my $agent = delete $cnf{agent}; + my $from = delete $cnf{from}; + my $def_headers = delete $cnf{default_headers}; + my $timeout = delete $cnf{timeout}; + $timeout = 3*60 unless defined $timeout; + my $local_address = delete $cnf{local_address}; + my $use_eval = delete $cnf{use_eval}; + $use_eval = 1 unless defined $use_eval; + my $parse_head = delete $cnf{parse_head}; + $parse_head = 1 unless defined $parse_head; + my $show_progress = delete $cnf{show_progress}; + my $max_size = delete $cnf{max_size}; + my $max_redirect = delete $cnf{max_redirect}; + $max_redirect = 7 unless defined $max_redirect; + my $env_proxy = delete $cnf{env_proxy}; + + my $cookie_jar = delete $cnf{cookie_jar}; + my $conn_cache = delete $cnf{conn_cache}; + my $keep_alive = delete $cnf{keep_alive}; + + Carp::croak("Can't mix conn_cache and keep_alive") + if $conn_cache && $keep_alive; + + + my $protocols_allowed = delete $cnf{protocols_allowed}; + my $protocols_forbidden = delete $cnf{protocols_forbidden}; + + my $requests_redirectable = delete $cnf{requests_redirectable}; + $requests_redirectable = ['GET', 'HEAD'] + unless defined $requests_redirectable; + + # Actually ""s are just as good as 0's, but for concision we'll just say: + Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!") + if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY'; + Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!") + if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY'; + Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!") + if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY'; + + + if (%cnf && $^W) { + Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}"); + } + + my $self = bless { + def_headers => $def_headers, + timeout => $timeout, + local_address => $local_address, + use_eval => $use_eval, + show_progress=> $show_progress, + max_size => $max_size, + max_redirect => $max_redirect, + proxy => {}, + no_proxy => [], + protocols_allowed => $protocols_allowed, + protocols_forbidden => $protocols_forbidden, + requests_redirectable => $requests_redirectable, + }, $class; + + $self->agent(defined($agent) ? $agent : $class->_agent) + if defined($agent) || !$def_headers || !$def_headers->header("User-Agent"); + $self->from($from) if $from; + $self->cookie_jar($cookie_jar) if $cookie_jar; + $self->parse_head($parse_head); + $self->env_proxy if $env_proxy; + + $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed; + $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden; + + if ($keep_alive) { + $conn_cache ||= { total_capacity => $keep_alive }; + } + $self->conn_cache($conn_cache) if $conn_cache; + + return $self; +} + + +sub send_request +{ + my($self, $request, $arg, $size) = @_; + my($method, $url) = ($request->method, $request->uri); + my $scheme = $url->scheme; + + local($SIG{__DIE__}); # protect against user defined die handlers + + $self->progress("begin", $request); + + my $response = $self->run_handlers("request_send", $request); + + unless ($response) { + my $protocol; + + { + # Honor object-specific restrictions by forcing protocol objects + # into class LWP::Protocol::nogo. + my $x; + if($x = $self->protocols_allowed) { + if (grep lc($_) eq $scheme, @$x) { + } + else { + require LWP::Protocol::nogo; + $protocol = LWP::Protocol::nogo->new; + } + } + elsif ($x = $self->protocols_forbidden) { + if(grep lc($_) eq $scheme, @$x) { + require LWP::Protocol::nogo; + $protocol = LWP::Protocol::nogo->new; + } + } + # else fall thru and create the protocol object normally + } + + # Locate protocol to use + my $proxy = $request->{proxy}; + if ($proxy) { + $scheme = $proxy->scheme; + } + + unless ($protocol) { + $protocol = eval { LWP::Protocol::create($scheme, $self) }; + if ($@) { + $@ =~ s/ at .* line \d+.*//s; # remove file/line number + $response = _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@); + if ($scheme eq "https") { + $response->message($response->message . " (Crypt::SSLeay or IO::Socket::SSL not installed)"); + $response->content_type("text/plain"); + $response->content(<<EOT); +LWP will support https URLs if either Crypt::SSLeay or IO::Socket::SSL +is installed. More information at +<http://search.cpan.org/dist/libwww-perl/README.SSL>. +EOT + } + } + } + + if (!$response && $self->{use_eval}) { + # we eval, and turn dies into responses below + eval { + $response = $protocol->request($request, $proxy, + $arg, $size, $self->{timeout}); + }; + if ($@) { + $@ =~ s/ at .* line \d+.*//s; # remove file/line number + $response = _new_response($request, + &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + $@); + } + } + elsif (!$response) { + $response = $protocol->request($request, $proxy, + $arg, $size, $self->{timeout}); + # XXX: Should we die unless $response->is_success ??? + } + } + + $response->request($request); # record request for reference + $response->header("Client-Date" => HTTP::Date::time2str(time)); + + $self->run_handlers("response_done", $response); + + $self->progress("end", $response); + return $response; +} + + +sub prepare_request +{ + my($self, $request) = @_; + die "Method missing" unless $request->method; + my $url = $request->uri; + die "URL missing" unless $url; + die "URL must be absolute" unless $url->scheme; + + $self->run_handlers("request_preprepare", $request); + + if (my $def_headers = $self->{def_headers}) { + for my $h ($def_headers->header_field_names) { + $request->init_header($h => [$def_headers->header($h)]); + } + } + + $self->run_handlers("request_prepare", $request); + + return $request; +} + + +sub simple_request +{ + my($self, $request, $arg, $size) = @_; + + # sanity check the request passed in + if (defined $request) { + if (ref $request) { + Carp::croak("You need a request object, not a " . ref($request) . " object") + if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or + !$request->can('method') or !$request->can('uri'); + } + else { + Carp::croak("You need a request object, not '$request'"); + } + } + else { + Carp::croak("No request object passed in"); + } + + eval { + $request = $self->prepare_request($request); + }; + if ($@) { + $@ =~ s/ at .* line \d+.*//s; # remove file/line number + return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@); + } + return $self->send_request($request, $arg, $size); +} + + +sub request +{ + my($self, $request, $arg, $size, $previous) = @_; + + my $response = $self->simple_request($request, $arg, $size); + $response->previous($previous) if $previous; + + if ($response->redirects >= $self->{max_redirect}) { + $response->header("Client-Warning" => + "Redirect loop detected (max_redirect = $self->{max_redirect})"); + return $response; + } + + if (my $req = $self->run_handlers("response_redirect", $response)) { + return $self->request($req, $arg, $size, $response); + } + + my $code = $response->code; + + if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or + $code == &HTTP::Status::RC_FOUND or + $code == &HTTP::Status::RC_SEE_OTHER or + $code == &HTTP::Status::RC_TEMPORARY_REDIRECT) + { + my $referral = $request->clone; + + # These headers should never be forwarded + $referral->remove_header('Host', 'Cookie'); + + if ($referral->header('Referer') && + $request->uri->scheme eq 'https' && + $referral->uri->scheme eq 'http') + { + # RFC 2616, section 15.1.3. + # https -> http redirect, suppressing Referer + $referral->remove_header('Referer'); + } + + if ($code == &HTTP::Status::RC_SEE_OTHER || + $code == &HTTP::Status::RC_FOUND) + { + my $method = uc($referral->method); + unless ($method eq "GET" || $method eq "HEAD") { + $referral->method("GET"); + $referral->content(""); + $referral->remove_content_headers; + } + } + + # And then we update the URL based on the Location:-header. + my $referral_uri = $response->header('Location'); + { + # Some servers erroneously return a relative URL for redirects, + # so make it absolute if it not already is. + local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; + my $base = $response->base; + $referral_uri = "" unless defined $referral_uri; + $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base) + ->abs($base); + } + $referral->uri($referral_uri); + + return $response unless $self->redirect_ok($referral, $response); + return $self->request($referral, $arg, $size, $response); + + } + elsif ($code == &HTTP::Status::RC_UNAUTHORIZED || + $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED + ) + { + my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED); + my $ch_header = $proxy ? "Proxy-Authenticate" : "WWW-Authenticate"; + my @challenge = $response->header($ch_header); + unless (@challenge) { + $response->header("Client-Warning" => + "Missing Authenticate header"); + return $response; + } + + require HTTP::Headers::Util; + CHALLENGE: for my $challenge (@challenge) { + $challenge =~ tr/,/;/; # "," is used to separate auth-params!! + ($challenge) = HTTP::Headers::Util::split_header_words($challenge); + my $scheme = shift(@$challenge); + shift(@$challenge); # no value + $challenge = { @$challenge }; # make rest into a hash + + unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) { + $response->header("Client-Warning" => + "Bad authentication scheme '$scheme'"); + return $response; + } + $scheme = $1; # untainted now + my $class = "LWP::Authen::\u$scheme"; + $class =~ s/-/_/g; + + no strict 'refs'; + unless (%{"$class\::"}) { + # try to load it + eval "require $class"; + if ($@) { + if ($@ =~ /^Can\'t locate/) { + $response->header("Client-Warning" => + "Unsupported authentication scheme '$scheme'"); + } + else { + $response->header("Client-Warning" => $@); + } + next CHALLENGE; + } + } + unless ($class->can("authenticate")) { + $response->header("Client-Warning" => + "Unsupported authentication scheme '$scheme'"); + next CHALLENGE; + } + return $class->authenticate($self, $proxy, $challenge, $response, + $request, $arg, $size); + } + return $response; + } + return $response; +} + + +# +# Now the shortcuts... +# +sub get { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters,1); + return $self->request( HTTP::Request::Common::GET( @parameters ), @suff ); +} + + +sub post { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1)); + return $self->request( HTTP::Request::Common::POST( @parameters ), @suff ); +} + + +sub head { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters,1); + return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff ); +} + + +sub _process_colonic_headers { + # Process :content_cb / :content_file / :read_size_hint headers. + my($self, $args, $start_index) = @_; + + my($arg, $size); + for(my $i = $start_index; $i < @$args; $i += 2) { + next unless defined $args->[$i]; + + #printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1]; + + if($args->[$i] eq ':content_cb') { + # Some sanity-checking... + $arg = $args->[$i + 1]; + Carp::croak("A :content_cb value can't be undef") unless defined $arg; + Carp::croak("A :content_cb value must be a coderef") + unless ref $arg and UNIVERSAL::isa($arg, 'CODE'); + + } + elsif ($args->[$i] eq ':content_file') { + $arg = $args->[$i + 1]; + + # Some sanity-checking... + Carp::croak("A :content_file value can't be undef") + unless defined $arg; + Carp::croak("A :content_file value can't be a reference") + if ref $arg; + Carp::croak("A :content_file value can't be \"\"") + unless length $arg; + + } + elsif ($args->[$i] eq ':read_size_hint') { + $size = $args->[$i + 1]; + # Bother checking it? + + } + else { + next; + } + splice @$args, $i, 2; + $i -= 2; + } + + # And return a suitable suffix-list for request(REQ,...) + + return unless defined $arg; + return $arg, $size if defined $size; + return $arg; +} + +my @ANI = qw(- \ | /); + +sub progress { + my($self, $status, $m) = @_; + return unless $self->{show_progress}; + + local($,, $\); + if ($status eq "begin") { + print STDERR "** ", $m->method, " ", $m->uri, " ==> "; + $self->{progress_start} = time; + $self->{progress_lastp} = ""; + $self->{progress_ani} = 0; + } + elsif ($status eq "end") { + delete $self->{progress_lastp}; + delete $self->{progress_ani}; + print STDERR $m->status_line; + my $t = time - delete $self->{progress_start}; + print STDERR " (${t}s)" if $t; + print STDERR "\n"; + } + elsif ($status eq "tick") { + print STDERR "$ANI[$self->{progress_ani}++]\b"; + $self->{progress_ani} %= @ANI; + } + else { + my $p = sprintf "%3.0f%%", $status * 100; + return if $p eq $self->{progress_lastp}; + print STDERR "$p\b\b\b\b"; + $self->{progress_lastp} = $p; + } + STDERR->flush; +} + + +# +# This whole allow/forbid thing is based on man 1 at's way of doing things. +# +sub is_protocol_supported +{ + my($self, $scheme) = @_; + if (ref $scheme) { + # assume we got a reference to an URI object + $scheme = $scheme->scheme; + } + else { + Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported") + if $scheme =~ /\W/; + $scheme = lc $scheme; + } + + my $x; + if(ref($self) and $x = $self->protocols_allowed) { + return 0 unless grep lc($_) eq $scheme, @$x; + } + elsif (ref($self) and $x = $self->protocols_forbidden) { + return 0 if grep lc($_) eq $scheme, @$x; + } + + local($SIG{__DIE__}); # protect against user defined die handlers + $x = LWP::Protocol::implementor($scheme); + return 1 if $x and $x ne 'LWP::Protocol::nogo'; + return 0; +} + + +sub protocols_allowed { shift->_elem('protocols_allowed' , @_) } +sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) } +sub requests_redirectable { shift->_elem('requests_redirectable', @_) } + + +sub redirect_ok +{ + # RFC 2616, section 10.3.2 and 10.3.3 say: + # If the 30[12] status code is received in response to a request other + # than GET or HEAD, the user agent MUST NOT automatically redirect the + # request unless it can be confirmed by the user, since this might + # change the conditions under which the request was issued. + + # Note that this routine used to be just: + # return 0 if $_[1]->method eq "POST"; return 1; + + my($self, $new_request, $response) = @_; + my $method = $response->request->method; + return 0 unless grep $_ eq $method, + @{ $self->requests_redirectable || [] }; + + if ($new_request->uri->scheme eq 'file') { + $response->header("Client-Warning" => + "Can't redirect to a file:// URL!"); + return 0; + } + + # Otherwise it's apparently okay... + return 1; +} + + +sub credentials +{ + my $self = shift; + my $netloc = lc(shift); + my $realm = shift || ""; + my $old = $self->{basic_authentication}{$netloc}{$realm}; + if (@_) { + $self->{basic_authentication}{$netloc}{$realm} = [@_]; + } + return unless $old; + return @$old if wantarray; + return join(":", @$old); +} + + +sub get_basic_credentials +{ + my($self, $realm, $uri, $proxy) = @_; + return if $proxy; + return $self->credentials($uri->host_port, $realm); +} + + +sub timeout { shift->_elem('timeout', @_); } +sub local_address{ shift->_elem('local_address',@_); } +sub max_size { shift->_elem('max_size', @_); } +sub max_redirect { shift->_elem('max_redirect', @_); } +sub show_progress{ shift->_elem('show_progress', @_); } + +sub parse_head { + my $self = shift; + if (@_) { + my $flag = shift; + my $parser; + my $old = $self->set_my_handler("response_header", $flag ? sub { + my($response, $ua) = @_; + require HTML::HeadParser; + $parser = HTML::HeadParser->new; + $parser->xml_mode(1) if $response->content_is_xhtml; + $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40; + + push(@{$response->{handlers}{response_data}}, { + callback => sub { + return unless $parser; + unless ($parser->parse($_[3])) { + my $h = $parser->header; + my $r = $_[0]; + for my $f ($h->header_field_names) { + $r->init_header($f, [$h->header($f)]); + } + undef($parser); + } + }, + }); + + } : undef, + m_media_type => "html", + ); + return !!$old; + } + else { + return !!$self->get_my_handler("response_header"); + } +} + +sub cookie_jar { + my $self = shift; + my $old = $self->{cookie_jar}; + if (@_) { + my $jar = shift; + if (ref($jar) eq "HASH") { + require HTTP::Cookies; + $jar = HTTP::Cookies->new(%$jar); + } + $self->{cookie_jar} = $jar; + $self->set_my_handler("request_prepare", + $jar ? sub { $jar->add_cookie_header($_[0]); } : undef, + ); + $self->set_my_handler("response_done", + $jar ? sub { $jar->extract_cookies($_[0]); } : undef, + ); + } + $old; +} + +sub default_headers { + my $self = shift; + my $old = $self->{def_headers} ||= HTTP::Headers->new; + if (@_) { + Carp::croak("default_headers not set to HTTP::Headers compatible object") + unless @_ == 1 && $_[0]->can("header_field_names"); + $self->{def_headers} = shift; + } + return $old; +} + +sub default_header { + my $self = shift; + return $self->default_headers->header(@_); +} + +sub _agent { "libwww-perl/$LWP::VERSION" } + +sub agent { + my $self = shift; + if (@_) { + my $agent = shift; + if ($agent) { + $agent .= $self->_agent if $agent =~ /\s+$/; + } + else { + undef($agent) + } + return $self->default_header("User-Agent", $agent); + } + return $self->default_header("User-Agent"); +} + +sub from { # legacy + my $self = shift; + return $self->default_header("From", @_); +} + + +sub conn_cache { + my $self = shift; + my $old = $self->{conn_cache}; + if (@_) { + my $cache = shift; + if (ref($cache) eq "HASH") { + require LWP::ConnCache; + $cache = LWP::ConnCache->new(%$cache); + } + $self->{conn_cache} = $cache; + } + $old; +} + + +sub add_handler { + my($self, $phase, $cb, %spec) = @_; + $spec{line} ||= join(":", (caller)[1,2]); + my $conf = $self->{handlers}{$phase} ||= do { + require HTTP::Config; + HTTP::Config->new; + }; + $conf->add(%spec, callback => $cb); +} + +sub set_my_handler { + my($self, $phase, $cb, %spec) = @_; + $spec{owner} = (caller(1))[3] unless exists $spec{owner}; + $self->remove_handler($phase, %spec); + $spec{line} ||= join(":", (caller)[1,2]); + $self->add_handler($phase, $cb, %spec) if $cb; +} + +sub get_my_handler { + my $self = shift; + my $phase = shift; + my $init = pop if @_ % 2; + my %spec = @_; + my $conf = $self->{handlers}{$phase}; + unless ($conf) { + return unless $init; + require HTTP::Config; + $conf = $self->{handlers}{$phase} = HTTP::Config->new; + } + $spec{owner} = (caller(1))[3] unless exists $spec{owner}; + my @h = $conf->find(%spec); + if (!@h && $init) { + if (ref($init) eq "CODE") { + $init->(\%spec); + } + elsif (ref($init) eq "HASH") { + while (my($k, $v) = each %$init) { + $spec{$k} = $v; + } + } + $spec{callback} ||= sub {}; + $spec{line} ||= join(":", (caller)[1,2]); + $conf->add(\%spec); + return \%spec; + } + return wantarray ? @h : $h[0]; +} + +sub remove_handler { + my($self, $phase, %spec) = @_; + if ($phase) { + my $conf = $self->{handlers}{$phase} || return; + my @h = $conf->remove(%spec); + delete $self->{handlers}{$phase} if $conf->empty; + return @h; + } + + return unless $self->{handlers}; + return map $self->remove_handler($_), sort keys %{$self->{handlers}}; +} + +sub handlers { + my($self, $phase, $o) = @_; + my @h; + if ($o->{handlers} && $o->{handlers}{$phase}) { + push(@h, @{$o->{handlers}{$phase}}); + } + if (my $conf = $self->{handlers}{$phase}) { + push(@h, $conf->matching($o)); + } + return @h; +} + +sub run_handlers { + my($self, $phase, $o) = @_; + if (defined(wantarray)) { + for my $h ($self->handlers($phase, $o)) { + my $ret = $h->{callback}->($o, $self, $h); + return $ret if $ret; + } + return undef; + } + + for my $h ($self->handlers($phase, $o)) { + $h->{callback}->($o, $self, $h); + } +} + + +# depreciated +sub use_eval { shift->_elem('use_eval', @_); } +sub use_alarm +{ + Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op") + if @_ > 1 && $^W; + ""; +} + + +sub clone +{ + my $self = shift; + my $copy = bless { %$self }, ref $self; # copy most fields + + delete $copy->{handlers}; + delete $copy->{conn_cache}; + + # copy any plain arrays and hashes; known not to need recursive copy + for my $k (qw(proxy no_proxy requests_redirectable)) { + next unless $copy->{$k}; + if (ref($copy->{$k}) eq "ARRAY") { + $copy->{$k} = [ @{$copy->{$k}} ]; + } + elsif (ref($copy->{$k}) eq "HASH") { + $copy->{$k} = { %{$copy->{$k}} }; + } + } + + if ($self->{def_headers}) { + $copy->{def_headers} = $self->{def_headers}->clone; + } + + # re-enable standard handlers + $copy->parse_head($self->parse_head); + + # no easy way to clone the cookie jar; so let's just remove it for now + $copy->cookie_jar(undef); + + $copy; +} + + +sub mirror +{ + my($self, $url, $file) = @_; + + my $request = HTTP::Request->new('GET', $url); + + # If the file exists, add a cache-related header + if ( -e $file ) { + my ($mtime) = ( stat($file) )[9]; + if ($mtime) { + $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) ); + } + } + my $tmpfile = "$file-$$"; + + my $response = $self->request($request, $tmpfile); + if ( $response->header('X-Died') ) { + die $response->header('X-Died'); + } + + # Only fetching a fresh copy of the would be considered success. + # If the file was not modified, "304" would returned, which + # is considered by HTTP::Status to be a "redirect", /not/ "success" + if ( $response->is_success ) { + my @stat = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!"; + my $file_length = $stat[7]; + my ($content_length) = $response->header('Content-length'); + + if ( defined $content_length and $file_length < $content_length ) { + unlink($tmpfile); + die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n"; + } + elsif ( defined $content_length and $file_length > $content_length ) { + unlink($tmpfile); + die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n"; + } + # The file was the expected length. + else { + # Replace the stale file with a fresh copy + if ( -e $file ) { + # Some dosish systems fail to rename if the target exists + chmod 0777, $file; + unlink $file; + } + rename( $tmpfile, $file ) + or die "Cannot rename '$tmpfile' to '$file': $!\n"; + + # make sure the file has the same last modification time + if ( my $lm = $response->last_modified ) { + utime $lm, $lm, $file; + } + } + } + # The local copy is fresh enough, so just delete the temp file + else { + unlink($tmpfile); + } + return $response; +} + + +sub _need_proxy { + my($req, $ua) = @_; + return if exists $req->{proxy}; + my $proxy = $ua->{proxy}{$req->uri->scheme} || return; + if ($ua->{no_proxy}) { + if (my $host = eval { $req->uri->host }) { + for my $domain (@{$ua->{no_proxy}}) { + if ($host =~ /\Q$domain\E$/) { + return; + } + } + } + } + $req->{proxy} = $HTTP::URI_CLASS->new($proxy); +} + + +sub proxy +{ + my $self = shift; + my $key = shift; + return map $self->proxy($_, @_), @$key if ref $key; + + Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/; + my $old = $self->{'proxy'}{$key}; + if (@_) { + my $url = shift; + if (defined($url) && length($url)) { + Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/; + Carp::croak("Bad http proxy specification '$url'") if $url =~ /^https?:/ && $url !~ m,^https?://\w,; + } + $self->{proxy}{$key} = $url; + $self->set_my_handler("request_preprepare", \&_need_proxy) + } + return $old; +} + + +sub env_proxy { + my ($self) = @_; + my($k,$v); + while(($k, $v) = each %ENV) { + if ($ENV{REQUEST_METHOD}) { + # Need to be careful when called in the CGI environment, as + # the HTTP_PROXY variable is under control of that other guy. + next if $k =~ /^HTTP_/; + $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY"; + } + $k = lc($k); + next unless $k =~ /^(.*)_proxy$/; + $k = $1; + if ($k eq 'no') { + $self->no_proxy(split(/\s*,\s*/, $v)); + } + else { + # Ignore random _proxy variables, allow only valid schemes + next unless $k =~ /^$URI::scheme_re\z/; + # Ignore xxx_proxy variables if xxx isn't a supported protocol + next unless LWP::Protocol::implementor($k); + $self->proxy($k, $v); + } + } +} + + +sub no_proxy { + my($self, @no) = @_; + if (@no) { + push(@{ $self->{'no_proxy'} }, @no); + } + else { + $self->{'no_proxy'} = []; + } +} + + +sub _new_response { + my($request, $code, $message) = @_; + my $response = HTTP::Response->new($code, $message); + $response->request($request); + $response->header("Client-Date" => HTTP::Date::time2str(time)); + $response->header("Client-Warning" => "Internal response"); + $response->header("Content-Type" => "text/plain"); + $response->content("$code $message\n"); + return $response; +} + + +1; + +__END__ + +=head1 NAME + +LWP::UserAgent - Web user agent class + +=head1 SYNOPSIS + + require LWP::UserAgent; + + my $ua = LWP::UserAgent->new; + $ua->timeout(10); + $ua->env_proxy; + + my $response = $ua->get('http://search.cpan.org/'); + + if ($response->is_success) { + print $response->decoded_content; # or whatever + } + else { + die $response->status_line; + } + +=head1 DESCRIPTION + +The C<LWP::UserAgent> is a class implementing a web user agent. +C<LWP::UserAgent> objects can be used to dispatch web requests. + +In normal use the application creates an C<LWP::UserAgent> object, and +then configures it with values for timeouts, proxies, name, etc. It +then creates an instance of C<HTTP::Request> for the request that +needs to be performed. This request is then passed to one of the +request method the UserAgent, which dispatches it using the relevant +protocol, and returns a C<HTTP::Response> object. There are +convenience methods for sending the most common request types: get(), +head() and post(). When using these methods then the creation of the +request object is hidden as shown in the synopsis above. + +The basic approach of the library is to use HTTP style communication +for all protocol schemes. This means that you will construct +C<HTTP::Request> objects and receive C<HTTP::Response> objects even +for non-HTTP resources like I<gopher> and I<ftp>. In order to achieve +even more similarity to HTTP style communications, gopher menus and +file directories are converted to HTML documents. + +=head1 CONSTRUCTOR METHODS + +The following constructor methods are available: + +=over 4 + +=item $ua = LWP::UserAgent->new( %options ) + +This method constructs a new C<LWP::UserAgent> object and returns it. +Key/value pair arguments may be provided to set up the initial state. +The following options correspond to attribute methods described below: + + KEY DEFAULT + ----------- -------------------- + agent "libwww-perl/#.###" + from undef + conn_cache undef + cookie_jar undef + default_headers HTTP::Headers->new + local_address undef + max_size undef + max_redirect 7 + parse_head 1 + protocols_allowed undef + protocols_forbidden undef + requests_redirectable ['GET', 'HEAD'] + timeout 180 + +The following additional options are also accepted: If the +C<env_proxy> option is passed in with a TRUE value, then proxy +settings are read from environment variables (see env_proxy() method +below). If the C<keep_alive> option is passed in, then a +C<LWP::ConnCache> is set up (see conn_cache() method below). The +C<keep_alive> value is passed on as the C<total_capacity> for the +connection cache. + +=item $ua->clone + +Returns a copy of the LWP::UserAgent object. + +=back + +=head1 ATTRIBUTES + +The settings of the configuration attributes modify the behaviour of the +C<LWP::UserAgent> when it dispatches requests. Most of these can also +be initialized by options passed to the constructor method. + +The following attribute methods are provided. The attribute value is +left unchanged if no argument is given. The return value from each +method is the old attribute value. + +=over + +=item $ua->agent + +=item $ua->agent( $product_id ) + +Get/set the product token that is used to identify the user agent on +the network. The agent value is sent as the "User-Agent" header in +the requests. The default is the string returned by the _agent() +method (see below). + +If the $product_id ends with space then the _agent() string is +appended to it. + +The user agent string should be one or more simple product identifiers +with an optional version number separated by the "/" character. +Examples are: + + $ua->agent('Checkbot/0.4 ' . $ua->_agent); + $ua->agent('Checkbot/0.4 '); # same as above + $ua->agent('Mozilla/5.0'); + $ua->agent(""); # don't identify + +=item $ua->_agent + +Returns the default agent identifier. This is a string of the form +"libwww-perl/#.###", where "#.###" is substituted with the version number +of this library. + +=item $ua->from + +=item $ua->from( $email_address ) + +Get/set the e-mail address for the human user who controls +the requesting user agent. The address should be machine-usable, as +defined in RFC 822. The C<from> value is send as the "From" header in +the requests. Example: + + $ua->from('gaas@cpan.org'); + +The default is to not send a "From" header. See the default_headers() +method for the more general interface that allow any header to be defaulted. + +=item $ua->cookie_jar + +=item $ua->cookie_jar( $cookie_jar_obj ) + +Get/set the cookie jar object to use. The only requirement is that +the cookie jar object must implement the extract_cookies($request) and +add_cookie_header($response) methods. These methods will then be +invoked by the user agent as requests are sent and responses are +received. Normally this will be a C<HTTP::Cookies> object or some +subclass. + +The default is to have no cookie_jar, i.e. never automatically add +"Cookie" headers to the requests. + +Shortcut: If a reference to a plain hash is passed in as the +$cookie_jar_object, then it is replaced with an instance of +C<HTTP::Cookies> that is initialized based on the hash. This form also +automatically loads the C<HTTP::Cookies> module. It means that: + + $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" }); + +is really just a shortcut for: + + require HTTP::Cookies; + $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt")); + +=item $ua->default_headers + +=item $ua->default_headers( $headers_obj ) + +Get/set the headers object that will provide default header values for +any requests sent. By default this will be an empty C<HTTP::Headers> +object. + +=item $ua->default_header( $field ) + +=item $ua->default_header( $field => $value ) + +This is just a short-cut for $ua->default_headers->header( $field => +$value ). Example: + + $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable()); + $ua->default_header('Accept-Language' => "no, en"); + +=item $ua->conn_cache + +=item $ua->conn_cache( $cache_obj ) + +Get/set the C<LWP::ConnCache> object to use. See L<LWP::ConnCache> +for details. + +=item $ua->credentials( $netloc, $realm ) + +=item $ua->credentials( $netloc, $realm, $uname, $pass ) + +Get/set the user name and password to be used for a realm. + +The $netloc is a string of the form "<host>:<port>". The username and +password will only be passed to this server. Example: + + $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret"); + +=item $ua->local_address + +=item $ua->local_address( $address ) + +Get/set the local interface to bind to for network connections. The interface +can be specified as a hostname or an IP address. This value is passed as the +C<LocalAddr> argument to L<IO::Socket::INET>. + +=item $ua->max_size + +=item $ua->max_size( $bytes ) + +Get/set the size limit for response content. The default is C<undef>, +which means that there is no limit. If the returned response content +is only partial, because the size limit was exceeded, then a +"Client-Aborted" header will be added to the response. The content +might end up longer than C<max_size> as we abort once appending a +chunk of data makes the length exceed the limit. The "Content-Length" +header, if present, will indicate the length of the full content and +will normally not be the same as C<< length($res->content) >>. + +=item $ua->max_redirect + +=item $ua->max_redirect( $n ) + +This reads or sets the object's limit of how many times it will obey +redirection responses in a given request cycle. + +By default, the value is 7. This means that if you call request() +method and the response is a redirect elsewhere which is in turn a +redirect, and so on seven times, then LWP gives up after that seventh +request. + +=item $ua->parse_head + +=item $ua->parse_head( $boolean ) + +Get/set a value indicating whether we should initialize response +headers from the E<lt>head> section of HTML documents. The default is +TRUE. Do not turn this off, unless you know what you are doing. + +=item $ua->protocols_allowed + +=item $ua->protocols_allowed( \@protocols ) + +This reads (or sets) this user agent's list of protocols that the +request methods will exclusively allow. The protocol names are case +insensitive. + +For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );> +means that this user agent will I<allow only> those protocols, +and attempts to use this user agent to access URLs with any other +schemes (like "ftp://...") will result in a 500 error. + +To delete the list, call: C<$ua-E<gt>protocols_allowed(undef)> + +By default, an object has neither a C<protocols_allowed> list, nor a +C<protocols_forbidden> list. + +Note that having a C<protocols_allowed> list causes any +C<protocols_forbidden> list to be ignored. + +=item $ua->protocols_forbidden + +=item $ua->protocols_forbidden( \@protocols ) + +This reads (or sets) this user agent's list of protocols that the +request method will I<not> allow. The protocol names are case +insensitive. + +For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );> +means that this user agent will I<not> allow those protocols, and +attempts to use this user agent to access URLs with those schemes +will result in a 500 error. + +To delete the list, call: C<$ua-E<gt>protocols_forbidden(undef)> + +=item $ua->requests_redirectable + +=item $ua->requests_redirectable( \@requests ) + +This reads or sets the object's list of request names that +C<$ua-E<gt>redirect_ok(...)> will allow redirection for. By +default, this is C<['GET', 'HEAD']>, as per RFC 2616. To +change to include 'POST', consider: + + push @{ $ua->requests_redirectable }, 'POST'; + +=item $ua->show_progress + +=item $ua->show_progress( $boolean ) + +Get/set a value indicating whether a progress bar should be displayed +on on the terminal as requests are processed. The default is FALSE. + +=item $ua->timeout + +=item $ua->timeout( $secs ) + +Get/set the timeout value in seconds. The default timeout() value is +180 seconds, i.e. 3 minutes. + +The requests is aborted if no activity on the connection to the server +is observed for C<timeout> seconds. This means that the time it takes +for the complete transaction and the request() method to actually +return might be longer. + +=back + +=head2 Proxy attributes + +The following methods set up when requests should be passed via a +proxy server. + +=over + +=item $ua->proxy(\@schemes, $proxy_url) + +=item $ua->proxy($scheme, $proxy_url) + +Set/retrieve proxy URL for a scheme: + + $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/'); + $ua->proxy('gopher', 'http://proxy.sn.no:8001/'); + +The first form specifies that the URL is to be used for proxying of +access methods listed in the list in the first method argument, +i.e. 'http' and 'ftp'. + +The second form shows a shorthand form for specifying +proxy URL for a single access scheme. + +=item $ua->no_proxy( $domain, ... ) + +Do not proxy requests to the given domains. Calling no_proxy without +any domains clears the list of domains. Eg: + + $ua->no_proxy('localhost', 'example.com'); + +=item $ua->env_proxy + +Load proxy settings from *_proxy environment variables. You might +specify proxies like this (sh-syntax): + + gopher_proxy=http://proxy.my.place/ + wais_proxy=http://proxy.my.place/ + no_proxy="localhost,example.com" + export gopher_proxy wais_proxy no_proxy + +csh or tcsh users should use the C<setenv> command to define these +environment variables. + +On systems with case insensitive environment variables there exists a +name clash between the CGI environment variables and the C<HTTP_PROXY> +environment variable normally picked up by env_proxy(). Because of +this C<HTTP_PROXY> is not honored for CGI scripts. The +C<CGI_HTTP_PROXY> environment variable can be used instead. + +=back + +=head2 Handlers + +Handlers are code that injected at various phases during the +processing of requests. The following methods are provided to manage +the active handlers: + +=over + +=item $ua->add_handler( $phase => \&cb, %matchspec ) + +Add handler to be invoked in the given processing phase. For how to +specify %matchspec see L<HTTP::Config/"Matching">. + +The possible values $phase and the corresponding callback signatures are: + +=over + +=item request_preprepare => sub { my($request, $ua, $h) = @_; ... } + +The handler is called before the C<request_prepare> and other standard +initialization of of the request. This can be used to set up headers +and attributes that the C<request_prepare> handler depends on. Proxy +initialization should take place here; but in general don't register +handlers for this phase. + +=item request_prepare => sub { my($request, $ua, $h) = @_; ... } + +The handler is called before the request is sent and can modify the +request any way it see fit. This can for instance be used to add +certain headers to specific requests. + +The method can assign a new request object to $_[0] to replace the +request that is sent fully. + +The return value from the callback is ignored. If an exceptions is +raised it will abort the request and make the request method return a +"400 Bad request" response. + +=item request_send => sub { my($request, $ua, $h) = @_; ... } + +This handler get a chance of handling requests before it's sent to the +protocol handlers. It should return an HTTP::Response object if it +wishes to terminate the processing; otherwise it should return nothing. + +The C<response_header> and C<response_data> handlers will not be +invoked for this response, but the C<response_done> will be. + +=item response_header => sub { my($response, $ua, $h) = @_; ... } + +This handler is called right after the response headers have been +received, but before any content data. The handler might set up +handlers for data and might croak to abort the request. + +The handler might set the $response->{default_add_content} value to +control if any received data should be added to the response object +directly. This will initially be false if the $ua->request() method +was called with a $content_file or $content_cb argument; otherwise true. + +=item response_data => sub { my($response, $ua, $h, $data) = @_; ... } + +This handlers is called for each chunk of data received for the +response. The handler might croak to abort the request. + +This handler need to return a TRUE value to be called again for +subsequent chunks for the same request. + +=item response_done => sub { my($response, $ua, $h) = @_; ... } + +The handler is called after the response has been fully received, but +before any redirect handling is attempted. The handler can be used to +extract information or modify the response. + +=item response_redirect => sub { my($response, $ua, $h) = @_; ... } + +The handler is called in $ua->request after C<response_done>. If the +handler return an HTTP::Request object we'll start over with processing +this request instead. + +=back + +=item $ua->remove_handler( undef, %matchspec ) + +=item $ua->remove_handler( $phase, %matchspec ) + +Remove handlers that match the given %matchspec. If $phase is not +provided remove handlers from all phases. + +Be careful as calling this function with %matchspec that is not not +specific enough can remove handlers not owned by you. It's probably +better to use the set_my_handler() method instead. + +The removed handlers are returned. + +=item $ua->set_my_handler( $phase, $cb, %matchspec ) + +Set handlers private to the executing subroutine. Works by defaulting +an C<owner> field to the %matchspec that holds the name of the called +subroutine. You might pass an explicit C<owner> to override this. + +If $cb is passed as C<undef>, remove the handler. + +=item $ua->get_my_handler( $phase, %matchspec ) + +=item $ua->get_my_handler( $phase, %matchspec, $init ) + +Will retrieve the matching handler as hash ref. + +If C<$init> is passed passed as a TRUE value, create and add the +handler if it's not found. If $init is a subroutine reference, then +it's called with the created handler hash as argument. This sub might +populate the hash with extra fields; especially the callback. If +$init is a hash reference, merge the hashes. + +=item $ua->handlers( $phase, $request ) + +=item $ua->handlers( $phase, $response ) + +Returns the handlers that apply to the given request or response at +the given processing phase. + +=back + +=head1 REQUEST METHODS + +The methods described in this section are used to dispatch requests +via the user agent. The following request methods are provided: + +=over + +=item $ua->get( $url ) + +=item $ua->get( $url , $field_name => $value, ... ) + +This method will dispatch a C<GET> request on the given $url. Further +arguments can be given to initialize the headers of the request. These +are given as separate name/value pairs. The return value is a +response object. See L<HTTP::Response> for a description of the +interface it provides. + +There will still be a response object returned when LWP can't connect to the +server specified in the URL or when other failures in protocol handlers occur. +These internal responses use the standard HTTP status codes, so the responses +can't be differentiated by testing the response status code alone. Error +responses that LWP generates internally will have the "Client-Warning" header +set to the value "Internal response". If you need to differentiate these +internal responses from responses that a remote server actually generates, you +need to test this header value. + +Fields names that start with ":" are special. These will not +initialize headers of the request but will determine how the response +content is treated. The following special field names are recognized: + + :content_file => $filename + :content_cb => \&callback + :read_size_hint => $bytes + +If a $filename is provided with the C<:content_file> option, then the +response content will be saved here instead of in the response +object. If a callback is provided with the C<:content_cb> option then +this function will be called for each chunk of the response content as +it is received from the server. If neither of these options are +given, then the response content will accumulate in the response +object itself. This might not be suitable for very large response +bodies. Only one of C<:content_file> or C<:content_cb> can be +specified. The content of unsuccessful responses will always +accumulate in the response object itself, regardless of the +C<:content_file> or C<:content_cb> options passed in. + +The C<:read_size_hint> option is passed to the protocol module which +will try to read data from the server in chunks of this size. A +smaller value for the C<:read_size_hint> will result in a higher +number of callback invocations. + +The callback function is called with 3 arguments: a chunk of data, a +reference to the response object, and a reference to the protocol +object. The callback can abort the request by invoking die(). The +exception message will show up as the "X-Died" header field in the +response returned by the get() function. + +=item $ua->head( $url ) + +=item $ua->head( $url , $field_name => $value, ... ) + +This method will dispatch a C<HEAD> request on the given $url. +Otherwise it works like the get() method described above. + +=item $ua->post( $url, \%form ) + +=item $ua->post( $url, \@form ) + +=item $ua->post( $url, \%form, $field_name => $value, ... ) + +=item $ua->post( $url, $field_name => $value,... Content => \%form ) + +=item $ua->post( $url, $field_name => $value,... Content => \@form ) + +=item $ua->post( $url, $field_name => $value,... Content => $content ) + +This method will dispatch a C<POST> request on the given $url, with +%form or @form providing the key/value pairs for the fill-in form +content. Additional headers and content options are the same as for +the get() method. + +This method will use the POST() function from C<HTTP::Request::Common> +to build the request. See L<HTTP::Request::Common> for a details on +how to pass form content and other advanced features. + +=item $ua->mirror( $url, $filename ) + +This method will get the document identified by $url and store it in +file called $filename. If the file already exists, then the request +will contain an "If-Modified-Since" header matching the modification +time of the file. If the document on the server has not changed since +this time, then nothing happens. If the document has been updated, it +will be downloaded again. The modification time of the file will be +forced to match that of the server. + +The return value is the the response object. + +=item $ua->request( $request ) + +=item $ua->request( $request, $content_file ) + +=item $ua->request( $request, $content_cb ) + +=item $ua->request( $request, $content_cb, $read_size_hint ) + +This method will dispatch the given $request object. Normally this +will be an instance of the C<HTTP::Request> class, but any object with +a similar interface will do. The return value is a response object. +See L<HTTP::Request> and L<HTTP::Response> for a description of the +interface provided by these classes. + +The request() method will process redirects and authentication +responses transparently. This means that it may actually send several +simple requests via the simple_request() method described below. + +The request methods described above; get(), head(), post() and +mirror(), will all dispatch the request they build via this method. +They are convenience methods that simply hides the creation of the +request object for you. + +The $content_file, $content_cb and $read_size_hint all correspond to +options described with the get() method above. + +You are allowed to use a CODE reference as C<content> in the request +object passed in. The C<content> function should return the content +when called. The content can be returned in chunks. The content +function will be invoked repeatedly until it return an empty string to +signal that there is no more content. + +=item $ua->simple_request( $request ) + +=item $ua->simple_request( $request, $content_file ) + +=item $ua->simple_request( $request, $content_cb ) + +=item $ua->simple_request( $request, $content_cb, $read_size_hint ) + +This method dispatches a single request and returns the response +received. Arguments are the same as for request() described above. + +The difference from request() is that simple_request() will not try to +handle redirects or authentication responses. The request() method +will in fact invoke this method for each simple request it sends. + +=item $ua->is_protocol_supported( $scheme ) + +You can use this method to test whether this user agent object supports the +specified C<scheme>. (The C<scheme> might be a string (like 'http' or +'ftp') or it might be an URI object reference.) + +Whether a scheme is supported, is determined by the user agent's +C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by +the capabilities of LWP. I.e., this will return TRUE only if LWP +supports this protocol I<and> it's permitted for this particular +object. + +=back + +=head2 Callback methods + +The following methods will be invoked as requests are processed. These +methods are documented here because subclasses of C<LWP::UserAgent> +might want to override their behaviour. + +=over + +=item $ua->prepare_request( $request ) + +This method is invoked by simple_request(). Its task is to modify the +given $request object by setting up various headers based on the +attributes of the user agent. The return value should normally be the +$request object passed in. If a different request object is returned +it will be the one actually processed. + +The headers affected by the base implementation are; "User-Agent", +"From", "Range" and "Cookie". + +=item $ua->redirect_ok( $prospective_request, $response ) + +This method is called by request() before it tries to follow a +redirection to the request in $response. This should return a TRUE +value if this redirection is permissible. The $prospective_request +will be the request to be sent if this method returns TRUE. + +The base implementation will return FALSE unless the method +is in the object's C<requests_redirectable> list, +FALSE if the proposed redirection is to a "file://..." +URL, and TRUE otherwise. + +=item $ua->get_basic_credentials( $realm, $uri, $isproxy ) + +This is called by request() to retrieve credentials for documents +protected by Basic or Digest Authentication. The arguments passed in +is the $realm provided by the server, the $uri requested and a boolean +flag to indicate if this is authentication against a proxy server. + +The method should return a username and password. It should return an +empty list to abort the authentication resolution attempt. Subclasses +can override this method to prompt the user for the information. An +example of this can be found in C<lwp-request> program distributed +with this library. + +The base implementation simply checks a set of pre-stored member +variables, set up with the credentials() method. + +=item $ua->progress( $status, $request_or_response ) + +This is called frequently as the response is received regardless of +how the content is processed. The method is called with $status +"begin" at the start of processing the request and with $state "end" +before the request method returns. In between these $status will be +the fraction of the response currently received or the string "tick" +if the fraction can't be calculated. + +When $status is "begin" the second argument is the request object, +otherwise it is the response object. + +=back + +=head1 SEE ALSO + +See L<LWP> for a complete overview of libwww-perl5. See L<lwpcook> +and the scripts F<lwp-request> and F<lwp-download> for examples of +usage. + +See L<HTTP::Request> and L<HTTP::Response> for a description of the +message objects dispatched and received. See L<HTTP::Request::Common> +and L<HTML::Form> for other ways to build request objects. + +See L<WWW::Mechanize> and L<WWW::Search> for examples of more +specialized user agents based on C<LWP::UserAgent>. + +=head1 COPYRIGHT + +Copyright 1995-2009 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/LWP/media.types b/Master/tlpkg/tlperl/lib/LWP/media.types new file mode 100644 index 00000000000..fbd54984d63 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/media.types @@ -0,0 +1,1064 @@ +# This is a comment. I love comments. + +# This file controls what Internet media types are sent to the client for +# given file extension(s). Sending the correct media type to the client +# is important so they know how to handle the content of the file. +# For more information about Internet media types, please read RFC 2045, +# 2046, 2047, 2048, and 2077. The Internet media type registry is +# at <http://www.iana.org/assignments/media-types/>. + +# MIME type Extensions +application/activemessage +application/andrew-inset ez +application/applefile +application/atom+xml atom +application/atomcat+xml atomcat +application/atomicmail +application/atomsvc+xml atomsvc +application/auth-policy+xml +application/batch-smtp +application/beep+xml +application/cals-1840 +application/ccxml+xml ccxml +application/cellml+xml +application/cnrp+xml +application/commonground +application/conference-info+xml +application/cpl+xml +application/csta+xml +application/cstadata+xml +application/cybercash +application/davmount+xml davmount +application/dca-rft +application/dec-dx +application/dialog-info+xml +application/dicom +application/dns +application/dvcs +application/ecmascript ecma +application/edi-consent +application/edi-x12 +application/edifact +application/epp+xml +application/eshop +application/fastinfoset +application/fastsoap +application/fits +application/font-tdpfr pfr +application/h224 +application/http +application/hyperstudio stk +application/iges +application/im-iscomposing+xml +application/index +application/index.cmd +application/index.obj +application/index.response +application/index.vnd +application/iotp +application/ipp +application/isup +application/javascript js +application/json json +application/kpml-request+xml +application/kpml-response+xml +application/lost+xml lostxml +application/mac-binhex40 hqx +application/mac-compactpro cpt +application/macwriteii +application/marc mrc +application/mathematica ma nb mb +application/mathml+xml mathml +application/mbms-associated-procedure-description+xml +application/mbms-deregister+xml +application/mbms-envelope+xml +application/mbms-msk+xml +application/mbms-msk-response+xml +application/mbms-protection-description+xml +application/mbms-reception-report+xml +application/mbms-register+xml +application/mbms-register-response+xml +application/mbms-user-service-description+xml +application/mbox mbox +application/media_control+xml +application/mediaservercontrol+xml mscml +application/mikey +application/moss-keys +application/moss-signature +application/mosskey-data +application/mosskey-request +application/mp4 mp4s +application/mpeg4-generic +application/mpeg4-iod +application/mpeg4-iod-xmt +application/msword doc dot +application/mxf mxf +application/nasdata +application/news-transmission +application/nss +application/ocsp-request +application/ocsp-response +application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc +application/oda oda +application/oebps-package+xml +application/ogg ogx +application/parityfec +application/patch-ops-error+xml xer +application/pdf pdf +application/pgp-encrypted pgp +application/pgp-keys +application/pgp-signature asc sig +application/pics-rules prf +application/pidf+xml +application/pidf-diff+xml +application/pkcs10 p10 +application/pkcs7-mime p7m p7c +application/pkcs7-signature p7s +application/pkix-cert cer +application/pkix-crl crl +application/pkix-pkipath pkipath +application/pkixcmp pki +application/pls+xml pls +application/poc-settings+xml +application/postscript ai eps ps +application/prs.alvestrand.titrax-sheet +application/prs.cww cww +application/prs.nprend +application/prs.plucker +application/qsig +application/rdf+xml rdf +application/reginfo+xml rif +application/relax-ng-compact-syntax rnc +application/remote-printing +application/resource-lists+xml rl +application/resource-lists-diff+xml rld +application/riscos +application/rlmi+xml +application/rls-services+xml rs +application/rsd+xml rsd +application/rss+xml rss +application/rtf rtf +application/rtx +application/samlassertion+xml +application/samlmetadata+xml +application/sbml+xml sbml +application/scvp-cv-request scq +application/scvp-cv-response scs +application/scvp-vp-request spq +application/scvp-vp-response spp +application/sdp sdp +application/set-payment +application/set-payment-initiation setpay +application/set-registration +application/set-registration-initiation setreg +application/sgml +application/sgml-open-catalog +application/shf+xml shf +application/sieve +application/simple-filter+xml +application/simple-message-summary +application/simplesymbolcontainer +application/slate +application/smil +application/smil+xml smi smil +application/soap+fastinfoset +application/soap+xml +application/sparql-query rq +application/sparql-results+xml srx +application/spirits-event+xml +application/srgs gram +application/srgs+xml grxml +application/ssml+xml ssml +application/timestamp-query +application/timestamp-reply +application/tve-trigger +application/ulpfec +application/vemmi +application/vividence.scriptfile +application/vnd.3gpp.bsf+xml +application/vnd.3gpp.pic-bw-large plb +application/vnd.3gpp.pic-bw-small psb +application/vnd.3gpp.pic-bw-var pvb +application/vnd.3gpp.sms +application/vnd.3gpp2.bcmcsinfo+xml +application/vnd.3gpp2.sms +application/vnd.3gpp2.tcap tcap +application/vnd.3m.post-it-notes pwn +application/vnd.accpac.simply.aso aso +application/vnd.accpac.simply.imp imp +application/vnd.acucobol acu +application/vnd.acucorp atc acutc +application/vnd.adobe.xdp+xml xdp +application/vnd.adobe.xfdf xfdf +application/vnd.aether.imp +application/vnd.americandynamics.acc acc +application/vnd.amiga.ami ami +application/vnd.anser-web-certificate-issue-initiation cii +application/vnd.anser-web-funds-transfer-initiation fti +application/vnd.antix.game-component atx +application/vnd.apple.installer+xml mpkg +application/vnd.arastra.swi swi +application/vnd.audiograph aep +application/vnd.autopackage +application/vnd.avistar+xml +application/vnd.blueice.multipass mpm +application/vnd.bmi bmi +application/vnd.businessobjects rep +application/vnd.cab-jscript +application/vnd.canon-cpdl +application/vnd.canon-lips +application/vnd.cendio.thinlinc.clientconf +application/vnd.chemdraw+xml cdxml +application/vnd.chipnuts.karaoke-mmd mmd +application/vnd.cinderella cdy +application/vnd.cirpack.isdn-ext +application/vnd.claymore cla +application/vnd.clonk.c4group c4g c4d c4f c4p c4u +application/vnd.commerce-battelle +application/vnd.commonspace csp cst +application/vnd.contact.cmsg cdbcmsg +application/vnd.cosmocaller cmc +application/vnd.crick.clicker clkx +application/vnd.crick.clicker.keyboard clkk +application/vnd.crick.clicker.palette clkp +application/vnd.crick.clicker.template clkt +application/vnd.crick.clicker.wordbank clkw +application/vnd.criticaltools.wbs+xml wbs +application/vnd.ctc-posml pml +application/vnd.ctct.ws+xml +application/vnd.cups-pdf +application/vnd.cups-postscript +application/vnd.cups-ppd ppd +application/vnd.cups-raster +application/vnd.cups-raw +application/vnd.curl curl +application/vnd.cybank +application/vnd.data-vision.rdz rdz +application/vnd.denovo.fcselayout-link fe_launch +application/vnd.dna dna +application/vnd.dolby.mlp mlp +application/vnd.dpgraph dpg +application/vnd.dreamfactory dfac +application/vnd.dvb.esgcontainer +application/vnd.dvb.ipdcesgaccess +application/vnd.dvb.iptv.alfec-base +application/vnd.dvb.iptv.alfec-enhancement +application/vnd.dxr +application/vnd.ecdis-update +application/vnd.ecowin.chart mag +application/vnd.ecowin.filerequest +application/vnd.ecowin.fileupdate +application/vnd.ecowin.series +application/vnd.ecowin.seriesrequest +application/vnd.ecowin.seriesupdate +application/vnd.enliven nml +application/vnd.epson.esf esf +application/vnd.epson.msf msf +application/vnd.epson.quickanime qam +application/vnd.epson.salt slt +application/vnd.epson.ssf ssf +application/vnd.ericsson.quickcall +application/vnd.eszigno3+xml es3 et3 +application/vnd.eudora.data +application/vnd.ezpix-album ez2 +application/vnd.ezpix-package ez3 +application/vnd.fdf fdf +application/vnd.ffsns +application/vnd.fints +application/vnd.flographit gph +application/vnd.fluxtime.clip ftc +application/vnd.font-fontforge-sfd +application/vnd.framemaker fm frame maker +application/vnd.frogans.fnc fnc +application/vnd.frogans.ltf ltf +application/vnd.fsc.weblaunch fsc +application/vnd.fujitsu.oasys oas +application/vnd.fujitsu.oasys2 oa2 +application/vnd.fujitsu.oasys3 oa3 +application/vnd.fujitsu.oasysgp fg5 +application/vnd.fujitsu.oasysprs bh2 +application/vnd.fujixerox.art-ex +application/vnd.fujixerox.art4 +application/vnd.fujixerox.hbpl +application/vnd.fujixerox.ddd ddd +application/vnd.fujixerox.docuworks xdw +application/vnd.fujixerox.docuworks.binder xbd +application/vnd.fut-misnet +application/vnd.fuzzysheet fzs +application/vnd.genomatix.tuxedo txd +application/vnd.gmx gmx +application/vnd.google-earth.kml+xml kml +application/vnd.google-earth.kmz kmz +application/vnd.grafeq gqf gqs +application/vnd.gridmp +application/vnd.groove-account gac +application/vnd.groove-help ghf +application/vnd.groove-identity-message gim +application/vnd.groove-injector grv +application/vnd.groove-tool-message gtm +application/vnd.groove-tool-template tpl +application/vnd.groove-vcard vcg +application/vnd.handheld-entertainment+xml zmm +application/vnd.hbci hbci +application/vnd.hcl-bireports +application/vnd.hhe.lesson-player les +application/vnd.hp-hpgl hpgl +application/vnd.hp-hpid hpid +application/vnd.hp-hps hps +application/vnd.hp-jlyt jlt +application/vnd.hp-pcl pcl +application/vnd.hp-pclxl pclxl +application/vnd.httphone +application/vnd.hydrostatix.sof-data sfd-hdstx +application/vnd.hzn-3d-crossword x3d +application/vnd.ibm.afplinedata +application/vnd.ibm.electronic-media +application/vnd.ibm.minipay mpy +application/vnd.ibm.modcap afp listafp list3820 +application/vnd.ibm.rights-management irm +application/vnd.ibm.secure-container sc +application/vnd.iccprofile icc icm +application/vnd.igloader igl +application/vnd.immervision-ivp ivp +application/vnd.immervision-ivu ivu +application/vnd.informedcontrol.rms+xml +application/vnd.intercon.formnet xpw xpx +application/vnd.intertrust.digibox +application/vnd.intertrust.nncp +application/vnd.intu.qbo qbo +application/vnd.intu.qfx qfx +application/vnd.iptc.g2.conceptitem+xml +application/vnd.iptc.g2.knowledgeitem+xml +application/vnd.iptc.g2.newsitem+xml +application/vnd.iptc.g2.packageitem+xml +application/vnd.ipunplugged.rcprofile rcprofile +application/vnd.irepository.package+xml irp +application/vnd.is-xpr xpr +application/vnd.jam jam +application/vnd.japannet-directory-service +application/vnd.japannet-jpnstore-wakeup +application/vnd.japannet-payment-wakeup +application/vnd.japannet-registration +application/vnd.japannet-registration-wakeup +application/vnd.japannet-setstore-wakeup +application/vnd.japannet-verification +application/vnd.japannet-verification-wakeup +application/vnd.jcp.javame.midlet-rms rms +application/vnd.jisp jisp +application/vnd.joost.joda-archive joda +application/vnd.kahootz ktz ktr +application/vnd.kde.karbon karbon +application/vnd.kde.kchart chrt +application/vnd.kde.kformula kfo +application/vnd.kde.kivio flw +application/vnd.kde.kontour kon +application/vnd.kde.kpresenter kpr kpt +application/vnd.kde.kspread ksp +application/vnd.kde.kword kwd kwt +application/vnd.kenameaapp htke +application/vnd.kidspiration kia +application/vnd.kinar kne knp +application/vnd.koan skp skd skt skm +application/vnd.kodak-descriptor sse +application/vnd.liberty-request+xml +application/vnd.llamagraphics.life-balance.desktop lbd +application/vnd.llamagraphics.life-balance.exchange+xml lbe +application/vnd.lotus-1-2-3 123 +application/vnd.lotus-approach apr +application/vnd.lotus-freelance pre +application/vnd.lotus-notes nsf +application/vnd.lotus-organizer org +application/vnd.lotus-screencam scm +application/vnd.lotus-wordpro lwp +application/vnd.macports.portpkg portpkg +application/vnd.marlin.drm.actiontoken+xml +application/vnd.marlin.drm.conftoken+xml +application/vnd.marlin.drm.license+xml +application/vnd.marlin.drm.mdcf +application/vnd.mcd mcd +application/vnd.medcalcdata mc1 +application/vnd.mediastation.cdkey cdkey +application/vnd.meridian-slingshot +application/vnd.mfer mwf +application/vnd.mfmp mfm +application/vnd.micrografx.flo flo +application/vnd.micrografx.igx igx +application/vnd.mif mif +application/vnd.minisoft-hp3000-save +application/vnd.mitsubishi.misty-guard.trustweb +application/vnd.mobius.daf daf +application/vnd.mobius.dis dis +application/vnd.mobius.mbk mbk +application/vnd.mobius.mqy mqy +application/vnd.mobius.msl msl +application/vnd.mobius.plc plc +application/vnd.mobius.txf txf +application/vnd.mophun.application mpn +application/vnd.mophun.certificate mpc +application/vnd.motorola.flexsuite +application/vnd.motorola.flexsuite.adsi +application/vnd.motorola.flexsuite.fis +application/vnd.motorola.flexsuite.gotap +application/vnd.motorola.flexsuite.kmr +application/vnd.motorola.flexsuite.ttc +application/vnd.motorola.flexsuite.wem +application/vnd.motorola.iprm +application/vnd.mozilla.xul+xml xul +application/vnd.ms-artgalry cil +application/vnd.ms-asf asf +application/vnd.ms-cab-compressed cab +application/vnd.ms-excel xls xlm xla xlc xlt xlw +application/vnd.ms-fontobject eot +application/vnd.ms-htmlhelp chm +application/vnd.ms-ims ims +application/vnd.ms-lrm lrm +application/vnd.ms-playready.initiator+xml +application/vnd.ms-powerpoint ppt pps pot +application/vnd.ms-project mpp mpt +application/vnd.ms-tnef +application/vnd.ms-wmdrm.lic-chlg-req +application/vnd.ms-wmdrm.lic-resp +application/vnd.ms-wmdrm.meter-chlg-req +application/vnd.ms-wmdrm.meter-resp +application/vnd.ms-works wps wks wcm wdb +application/vnd.ms-wpl wpl +application/vnd.ms-xpsdocument xps +application/vnd.mseq mseq +application/vnd.msign +application/vnd.multiad.creator +application/vnd.multiad.creator.cif +application/vnd.music-niff +application/vnd.musician mus +application/vnd.muvee.style msty +application/vnd.ncd.control +application/vnd.ncd.reference +application/vnd.nervana +application/vnd.netfpx +application/vnd.neurolanguage.nlu nlu +application/vnd.noblenet-directory nnd +application/vnd.noblenet-sealer nns +application/vnd.noblenet-web nnw +application/vnd.nokia.catalogs +application/vnd.nokia.conml+wbxml +application/vnd.nokia.conml+xml +application/vnd.nokia.isds-radio-presets +application/vnd.nokia.iptv.config+xml +application/vnd.nokia.landmark+wbxml +application/vnd.nokia.landmark+xml +application/vnd.nokia.landmarkcollection+xml +application/vnd.nokia.n-gage.ac+xml +application/vnd.nokia.n-gage.data ngdat +application/vnd.nokia.n-gage.symbian.install n-gage +application/vnd.nokia.ncd +application/vnd.nokia.pcd+wbxml +application/vnd.nokia.pcd+xml +application/vnd.nokia.radio-preset rpst +application/vnd.nokia.radio-presets rpss +application/vnd.novadigm.edm edm +application/vnd.novadigm.edx edx +application/vnd.novadigm.ext ext +application/vnd.oasis.opendocument.chart odc +application/vnd.oasis.opendocument.chart-template otc +application/vnd.oasis.opendocument.formula odf +application/vnd.oasis.opendocument.formula-template otf +application/vnd.oasis.opendocument.graphics odg +application/vnd.oasis.opendocument.graphics-template otg +application/vnd.oasis.opendocument.image odi +application/vnd.oasis.opendocument.image-template oti +application/vnd.oasis.opendocument.presentation odp +application/vnd.oasis.opendocument.presentation-template otp +application/vnd.oasis.opendocument.spreadsheet ods +application/vnd.oasis.opendocument.spreadsheet-template ots +application/vnd.oasis.opendocument.text odt +application/vnd.oasis.opendocument.text-master otm +application/vnd.oasis.opendocument.text-template ott +application/vnd.oasis.opendocument.text-web oth +application/vnd.obn +application/vnd.olpc-sugar xo +application/vnd.oma-scws-config +application/vnd.oma-scws-http-request +application/vnd.oma-scws-http-response +application/vnd.oma.bcast.associated-procedure-parameter+xml +application/vnd.oma.bcast.drm-trigger+xml +application/vnd.oma.bcast.imd+xml +application/vnd.oma.bcast.ltkm +application/vnd.oma.bcast.notification+xml +application/vnd.oma.bcast.provisioningtrigger +application/vnd.oma.bcast.sgboot +application/vnd.oma.bcast.sgdd+xml +application/vnd.oma.bcast.sgdu +application/vnd.oma.bcast.simple-symbol-container +application/vnd.oma.bcast.smartcard-trigger+xml +application/vnd.oma.bcast.sprov+xml +application/vnd.oma.bcast.stkm +application/vnd.oma.dcd +application/vnd.oma.dcdc +application/vnd.oma.dd2+xml dd2 +application/vnd.oma.drm.risd+xml +application/vnd.oma.group-usage-list+xml +application/vnd.oma.poc.detailed-progress-report+xml +application/vnd.oma.poc.final-report+xml +application/vnd.oma.poc.groups+xml +application/vnd.oma.poc.invocation-descriptor+xml +application/vnd.oma.poc.optimized-progress-report+xml +application/vnd.oma.xcap-directory+xml +application/vnd.omads-email+xml +application/vnd.omads-file+xml +application/vnd.omads-folder+xml +application/vnd.omaloc-supl-init +application/vnd.openofficeorg.extension oxt +application/vnd.osa.netdeploy +application/vnd.osgi.dp dp +application/vnd.otps.ct-kip+xml +application/vnd.palm prc pdb pqa oprc +application/vnd.paos.xml +application/vnd.pg.format str +application/vnd.pg.osasli ei6 +application/vnd.piaccess.application-licence +application/vnd.picsel efif +application/vnd.poc.group-advertisement+xml +application/vnd.pocketlearn plf +application/vnd.powerbuilder6 pbd +application/vnd.powerbuilder6-s +application/vnd.powerbuilder7 +application/vnd.powerbuilder7-s +application/vnd.powerbuilder75 +application/vnd.powerbuilder75-s +application/vnd.preminet +application/vnd.previewsystems.box box +application/vnd.proteus.magazine mgz +application/vnd.publishare-delta-tree qps +application/vnd.pvi.ptid1 ptid +application/vnd.pwg-multiplexed +application/vnd.pwg-xhtml-print+xml +application/vnd.qualcomm.brew-app-res +application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb +application/vnd.rapid +application/vnd.recordare.musicxml mxl +application/vnd.recordare.musicxml+xml +application/vnd.renlearn.rlprint +application/vnd.rn-realmedia rm +application/vnd.route66.link66+xml link66 +application/vnd.ruckus.download +application/vnd.s3sms +application/vnd.sbm.mid2 +application/vnd.scribus +application/vnd.sealed.3df +application/vnd.sealed.csf +application/vnd.sealed.doc +application/vnd.sealed.eml +application/vnd.sealed.mht +application/vnd.sealed.net +application/vnd.sealed.ppt +application/vnd.sealed.tiff +application/vnd.sealed.xls +application/vnd.sealedmedia.softseal.html +application/vnd.sealedmedia.softseal.pdf +application/vnd.seemail see +application/vnd.sema sema +application/vnd.semd semd +application/vnd.semf semf +application/vnd.shana.informed.formdata ifm +application/vnd.shana.informed.formtemplate itp +application/vnd.shana.informed.interchange iif +application/vnd.shana.informed.package ipk +application/vnd.simtech-mindmapper twd twds +application/vnd.smaf mmf +application/vnd.software602.filler.form+xml +application/vnd.software602.filler.form-xml-zip +application/vnd.solent.sdkm+xml sdkm sdkd +application/vnd.spotfire.dxp dxp +application/vnd.spotfire.sfs sfs +application/vnd.sss-cod +application/vnd.sss-dtf +application/vnd.sss-ntf +application/vnd.street-stream +application/vnd.sun.wadl+xml +application/vnd.sus-calendar sus susp +application/vnd.svd svd +application/vnd.swiftview-ics +application/vnd.syncml+xml xsm +application/vnd.syncml.dm+wbxml bdm +application/vnd.syncml.dm+xml xdm +application/vnd.syncml.ds.notification +application/vnd.tao.intent-module-archive tao +application/vnd.tmobile-livetv tmo +application/vnd.trid.tpt tpt +application/vnd.triscape.mxs mxs +application/vnd.trueapp tra +application/vnd.truedoc +application/vnd.ufdl ufd ufdl +application/vnd.uiq.theme utz +application/vnd.umajin umj +application/vnd.unity unityweb +application/vnd.uoml+xml uoml +application/vnd.uplanet.alert +application/vnd.uplanet.alert-wbxml +application/vnd.uplanet.bearer-choice +application/vnd.uplanet.bearer-choice-wbxml +application/vnd.uplanet.cacheop +application/vnd.uplanet.cacheop-wbxml +application/vnd.uplanet.channel +application/vnd.uplanet.channel-wbxml +application/vnd.uplanet.list +application/vnd.uplanet.list-wbxml +application/vnd.uplanet.listcmd +application/vnd.uplanet.listcmd-wbxml +application/vnd.uplanet.signal +application/vnd.vcx vcx +application/vnd.vd-study +application/vnd.vectorworks +application/vnd.vidsoft.vidconference +application/vnd.visio vsd vst vss vsw +application/vnd.visionary vis +application/vnd.vividence.scriptfile +application/vnd.vsf vsf +application/vnd.wap.sic +application/vnd.wap.slc +application/vnd.wap.wbxml wbxml +application/vnd.wap.wmlc wmlc +application/vnd.wap.wmlscriptc wmlsc +application/vnd.webturbo wtb +application/vnd.wfa.wsc +application/vnd.wmc +application/vnd.wmf.bootstrap +application/vnd.wordperfect wpd +application/vnd.wqd wqd +application/vnd.wrq-hp3000-labelled +application/vnd.wt.stf stf +application/vnd.wv.csp+wbxml +application/vnd.wv.csp+xml +application/vnd.wv.ssp+xml +application/vnd.xara xar +application/vnd.xfdl xfdl +application/vnd.xmi+xml +application/vnd.xmpie.cpkg +application/vnd.xmpie.dpkg +application/vnd.xmpie.plan +application/vnd.xmpie.ppkg +application/vnd.xmpie.xlim +application/vnd.yamaha.hv-dic hvd +application/vnd.yamaha.hv-script hvs +application/vnd.yamaha.hv-voice hvp +application/vnd.yamaha.smaf-audio saf +application/vnd.yamaha.smaf-phrase spf +application/vnd.yellowriver-custom-menu cmp +application/vnd.zzazz.deck+xml zaz +application/voicexml+xml vxml +application/watcherinfo+xml +application/whoispp-query +application/whoispp-response +application/winhlp hlp +application/wita +application/wordperfect5.1 +application/wsdl+xml wsdl +application/wspolicy+xml wspolicy +application/x-ace-compressed ace +application/x-bcpio bcpio +application/x-bittorrent torrent +application/x-bzip bz +application/x-bzip2 bz2 boz +application/x-cdlink vcd +application/x-chat chat +application/x-chess-pgn pgn +application/x-compress +application/x-cpio cpio +application/x-csh csh +application/x-director dcr dir dxr fgd +application/x-dvi dvi +application/x-futuresplash spl +application/x-gtar gtar +application/x-gzip +application/x-hdf hdf +application/x-latex latex +application/x-ms-wmd wmd +application/x-ms-wmz wmz +application/x-msaccess mdb +application/x-msbinder obd +application/x-mscardfile crd +application/x-msclip clp +application/x-msdownload exe dll com bat msi +application/x-msmediaview mvb m13 m14 +application/x-msmetafile wmf +application/x-msmoney mny +application/x-mspublisher pub +application/x-msschedule scd +application/x-msterminal trm +application/x-mswrite wri +application/x-netcdf nc cdf +application/x-pkcs12 p12 pfx +application/x-pkcs7-certificates p7b spc +application/x-pkcs7-certreqresp p7r +application/x-rar-compressed rar +application/x-sh sh +application/x-shar shar +application/x-shockwave-flash swf +application/x-stuffit sit +application/x-stuffitx sitx +application/x-sv4cpio sv4cpio +application/x-sv4crc sv4crc +application/x-tar tar +application/x-tcl tcl +application/x-tex tex +application/x-texinfo texinfo texi +application/x-ustar ustar +application/x-wais-source src +application/x-x509-ca-cert der crt +application/x400-bp +application/xcap-att+xml +application/xcap-caps+xml +application/xcap-el+xml +application/xcap-error+xml +application/xcap-ns+xml +application/xenc+xml xenc +application/xhtml+xml xhtml xht +application/xml xml xsl +application/xml-dtd dtd +application/xml-external-parsed-entity +application/xmpp+xml +application/xop+xml xop +application/xslt+xml xslt +application/xspf+xml xspf +application/xv+xml mxml xhvml xvml xvm +application/zip zip +audio/32kadpcm +audio/3gpp +audio/3gpp2 +audio/ac3 +audio/amr +audio/amr-wb +audio/amr-wb+ +audio/asc +audio/basic au snd +audio/bv16 +audio/bv32 +audio/clearmode +audio/cn +audio/dat12 +audio/dls +audio/dsr-es201108 +audio/dsr-es202050 +audio/dsr-es202211 +audio/dsr-es202212 +audio/dvi4 +audio/eac3 +audio/evrc +audio/evrc-qcp +audio/evrc0 +audio/evrc1 +audio/evrcb +audio/evrcb0 +audio/evrcb1 +audio/evrcwb +audio/evrcwb0 +audio/evrcwb1 +audio/g722 +audio/g7221 +audio/g723 +audio/g726-16 +audio/g726-24 +audio/g726-32 +audio/g726-40 +audio/g728 +audio/g729 +audio/g7291 +audio/g729d +audio/g729e +audio/gsm +audio/gsm-efr +audio/ilbc +audio/l16 +audio/l20 +audio/l24 +audio/l8 +audio/lpc +audio/midi mid midi kar rmi +audio/mobile-xmf +audio/mp4 mp4a +audio/mp4a-latm +audio/mpa +audio/mpa-robust +audio/mpeg mpga mp2 mp2a mp3 m2a m3a +audio/mpeg4-generic +audio/ogg oga ogg spx +audio/parityfec +audio/pcma +audio/pcmu +audio/prs.sid +audio/qcelp +audio/red +audio/rtp-enc-aescm128 +audio/rtp-midi +audio/rtx +audio/smv +audio/smv0 +audio/smv-qcp +audio/sp-midi +audio/t140c +audio/t38 +audio/telephone-event +audio/tone +audio/ulpfec +audio/vdvi +audio/vmr-wb +audio/vnd.3gpp.iufp +audio/vnd.4sb +audio/vnd.audiokoz +audio/vnd.celp +audio/vnd.cisco.nse +audio/vnd.cmles.radio-events +audio/vnd.cns.anp1 +audio/vnd.cns.inf1 +audio/vnd.digital-winds eol +audio/vnd.dlna.adts +audio/vnd.dolby.mlp +audio/vnd.dts dts +audio/vnd.dts.hd dtshd +audio/vnd.everad.plj +audio/vnd.hns.audio +audio/vnd.lucent.voice lvp +audio/vnd.ms-playready.media.pya pya +audio/vnd.nokia.mobile-xmf +audio/vnd.nortel.vbk +audio/vnd.nuera.ecelp4800 ecelp4800 +audio/vnd.nuera.ecelp7470 ecelp7470 +audio/vnd.nuera.ecelp9600 ecelp9600 +audio/vnd.octel.sbc +audio/vnd.qcelp +audio/vnd.rhetorex.32kadpcm +audio/vnd.sealedmedia.softseal.mpeg +audio/vnd.vmx.cvsd +audio/vorbis +audio/vorbis-config +audio/wav wav +audio/x-aiff aif aiff aifc +audio/x-mpegurl m3u +audio/x-ms-wax wax +audio/x-ms-wma wma +audio/x-pn-realaudio ram ra +audio/x-pn-realaudio-plugin rmp +audio/x-wav wav +chemical/x-cdx cdx +chemical/x-cif cif +chemical/x-cmdf cmdf +chemical/x-cml cml +chemical/x-csml csml +chemical/x-pdb pdb +chemical/x-xyz xyz +image/bmp bmp +image/cgm cgm +image/fits +image/g3fax g3 +image/gif gif +image/ief ief +image/jp2 +image/jpeg jpeg jpg jpe +image/jpm +image/jpx +image/naplps +image/png png +image/prs.btif btif +image/prs.pti +image/svg+xml svg svgz +image/t38 +image/tiff tiff tif +image/tiff-fx +image/vnd.adobe.photoshop psd +image/vnd.cns.inf2 +image/vnd.djvu djvu djv +image/vnd.dwg dwg +image/vnd.dxf dxf +image/vnd.fastbidsheet fbs +image/vnd.fpx fpx +image/vnd.fst fst +image/vnd.fujixerox.edmics-mmr mmr +image/vnd.fujixerox.edmics-rlc rlc +image/vnd.globalgraphics.pgb +image/vnd.microsoft.icon +image/vnd.mix +image/vnd.ms-modi mdi +image/vnd.net-fpx npx +image/vnd.sealed.png +image/vnd.sealedmedia.softseal.gif +image/vnd.sealedmedia.softseal.jpg +image/vnd.svf +image/vnd.wap.wbmp wbmp +image/vnd.xiff xif +image/x-cmu-raster ras +image/x-cmx cmx +image/x-icon ico +image/x-pcx pcx +image/x-pict pic pct +image/x-portable-anymap pnm +image/x-portable-bitmap pbm +image/x-portable-graymap pgm +image/x-portable-pixmap ppm +image/x-rgb rgb +image/x-xbitmap xbm +image/x-xpixmap xpm +image/x-xwindowdump xwd +message/cpim +message/delivery-status +message/disposition-notification +message/external-body +message/global +message/global-delivery-status +message/global-disposition-notification +message/global-headers +message/http +message/news +message/partial +message/rfc822 eml mime +message/s-http +message/sip +message/sipfrag +message/tracking-status +message/vnd.si.simp +model/iges igs iges +model/mesh msh mesh silo +model/vnd.dwf dwf +model/vnd.flatland.3dml +model/vnd.gdl gdl +model/vnd.gs.gdl +model/vnd.gtw gtw +model/vnd.moml+xml +model/vnd.mts mts +model/vnd.parasolid.transmit.binary +model/vnd.parasolid.transmit.text +model/vnd.vtu vtu +model/vrml wrl vrml +multipart/alternative +multipart/appledouble +multipart/byteranges +multipart/digest +multipart/encrypted +multipart/form-data +multipart/header-set +multipart/mixed +multipart/parallel +multipart/related +multipart/report +multipart/signed +multipart/voice-message +text/calendar ics ifb +text/css css +text/csv csv +text/directory +text/dns +text/enriched +text/html html htm +text/parityfec +text/plain txt text conf def list log in +text/prs.fallenstein.rst +text/prs.lines.tag dsc +text/red +text/rfc822-headers +text/richtext rtx +text/rtf +text/rtp-enc-aescm128 +text/rtx +text/sgml sgml sgm +text/t140 +text/tab-separated-values tsv +text/troff t tr roff man me ms +text/ulpfec +text/uri-list uri uris urls +text/vnd.abc +text/vnd.curl +text/vnd.dmclientscript +text/vnd.esmertec.theme-descriptor +text/vnd.fly fly +text/vnd.fmi.flexstor flx +text/vnd.graphviz gv +text/vnd.in3d.3dml 3dml +text/vnd.in3d.spot spot +text/vnd.iptc.newsml +text/vnd.iptc.nitf +text/vnd.latex-z +text/vnd.motorola.reflex +text/vnd.ms-mediapackage +text/vnd.net2phone.commcenter.command +text/vnd.si.uricatalogue +text/vnd.sun.j2me.app-descriptor jad +text/vnd.trolltech.linguist +text/vnd.wap.si +text/vnd.wap.sl +text/vnd.wap.wml wml +text/vnd.wap.wmlscript wmls +text/x-asm s asm +text/x-c c cc cxx cpp h hh dic +text/x-fortran f for f77 f90 +text/x-pascal p pas +text/x-java-source java +text/x-setext etx +text/x-uuencode uu +text/x-vcalendar vcs +text/x-vcard vcf +text/xml +text/xml-external-parsed-entity +video/3gpp 3gp +video/3gpp-tt +video/3gpp2 3g2 +video/bmpeg +video/bt656 +video/celb +video/dv +video/h261 h261 +video/h263 h263 +video/h263-1998 +video/h263-2000 +video/h264 h264 +video/jpeg jpgv +video/jpeg2000 +video/jpm jpm jpgm +video/mj2 mj2 mjp2 +video/mp1s +video/mp2p +video/mp2t +video/mp4 mp4 mp4v mpg4 +video/mp4v-es +video/mpeg mpeg mpg mpe m1v m2v +video/mpeg4-generic +video/mpv +video/nv +video/ogg ogv +video/parityfec +video/pointer +video/quicktime qt mov +video/raw +video/rtp-enc-aescm128 +video/rtx +video/smpte292m +video/ulpfec +video/vc1 +video/vnd.cctv +video/vnd.dlna.mpeg-tts +video/vnd.fvt fvt +video/vnd.hns.video +video/vnd.iptvforum.1dparityfec-1010 +video/vnd.iptvforum.1dparityfec-2005 +video/vnd.iptvforum.2dparityfec-1010 +video/vnd.iptvforum.2dparityfec-2005 +video/vnd.iptvforum.ttsavc +video/vnd.iptvforum.ttsmpeg2 +video/vnd.motorola.video +video/vnd.motorola.videop +video/vnd.mpegurl mxu m4u +video/vnd.ms-playready.media.pyv pyv +video/vnd.nokia.interleaved-multimedia +video/vnd.nokia.videovoip +video/vnd.objectvideo +video/vnd.sealed.mpeg1 +video/vnd.sealed.mpeg4 +video/vnd.sealed.swf +video/vnd.sealedmedia.softseal.mov +video/vnd.vivo viv +video/x-fli fli +video/x-ms-asf asf asx +video/x-ms-wm wm +video/x-ms-wmv wmv +video/x-ms-wmx wmx +video/x-ms-wvx wvx +video/x-msvideo avi +video/x-sgi-movie movie +x-conference/x-cooltalk ice diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP.pm b/Master/tlpkg/tlperl/lib/Net/HTTP.pm new file mode 100644 index 00000000000..120de285f71 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Net/HTTP.pm @@ -0,0 +1,279 @@ +package Net::HTTP; + +use strict; +use vars qw($VERSION @ISA $SOCKET_CLASS); + +$VERSION = "5.834"; +unless ($SOCKET_CLASS) { + eval { require IO::Socket::INET } || require IO::Socket; + $SOCKET_CLASS = "IO::Socket::INET"; +} +require Net::HTTP::Methods; +require Carp; + +@ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods'); + +sub new { + my $class = shift; + Carp::croak("No Host option provided") unless @_; + $class->SUPER::new(@_); +} + +sub configure { + my($self, $cnf) = @_; + $self->http_configure($cnf); +} + +sub http_connect { + my($self, $cnf) = @_; + $self->SUPER::configure($cnf); +} + +1; + +__END__ + +=head1 NAME + +Net::HTTP - Low-level HTTP connection (client) + +=head1 SYNOPSIS + + use Net::HTTP; + my $s = Net::HTTP->new(Host => "www.perl.com") || die $@; + $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0"); + my($code, $mess, %h) = $s->read_response_headers; + + while (1) { + my $buf; + my $n = $s->read_entity_body($buf, 1024); + die "read failed: $!" unless defined $n; + last unless $n; + print $buf; + } + +=head1 DESCRIPTION + +The C<Net::HTTP> class is a low-level HTTP client. An instance of the +C<Net::HTTP> class represents a connection to an HTTP server. The +HTTP protocol is described in RFC 2616. The C<Net::HTTP> class +supports C<HTTP/1.0> and C<HTTP/1.1>. + +C<Net::HTTP> is a sub-class of C<IO::Socket::INET>. You can mix the +methods described below with reading and writing from the socket +directly. This is not necessary a good idea, unless you know what you +are doing. + +The following methods are provided (in addition to those of +C<IO::Socket::INET>): + +=over + +=item $s = Net::HTTP->new( %options ) + +The C<Net::HTTP> constructor method takes the same options as +C<IO::Socket::INET>'s as well as these: + + Host: Initial host attribute value + KeepAlive: Initial keep_alive attribute value + SendTE: Initial send_te attribute_value + HTTPVersion: Initial http_version attribute value + PeerHTTPVersion: Initial peer_http_version attribute value + MaxLineLength: Initial max_line_length attribute value + MaxHeaderLines: Initial max_header_lines attribute value + +The C<Host> option is also the default for C<IO::Socket::INET>'s +C<PeerAddr>. The C<PeerPort> defaults to 80 if not provided. + +The C<Listen> option provided by C<IO::Socket::INET>'s constructor +method is not allowed. + +If unable to connect to the given HTTP server then the constructor +returns C<undef> and $@ contains the reason. After a successful +connect, a C<Net:HTTP> object is returned. + +=item $s->host + +Get/set the default value of the C<Host> header to send. The $host +must not be set to an empty string (or C<undef>) for HTTP/1.1. + +=item $s->keep_alive + +Get/set the I<keep-alive> value. If this value is TRUE then the +request will be sent with headers indicating that the server should try +to keep the connection open so that multiple requests can be sent. + +The actual headers set will depend on the value of the C<http_version> +and C<peer_http_version> attributes. + +=item $s->send_te + +Get/set the a value indicating if the request will be sent with a "TE" +header to indicate the transfer encodings that the server can choose to +use. The list of encodings announced as accepted by this client depends +on availability of the following modules: C<Compress::Raw::Zlib> for +I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>. + +=item $s->http_version + +Get/set the HTTP version number that this client should announce. +This value can only be set to "1.0" or "1.1". The default is "1.1". + +=item $s->peer_http_version + +Get/set the protocol version number of our peer. This value will +initially be "1.0", but will be updated by a successful +read_response_headers() method call. + +=item $s->max_line_length + +Get/set a limit on the length of response line and response header +lines. The default is 8192. A value of 0 means no limit. + +=item $s->max_header_length + +Get/set a limit on the number of header lines that a response can +have. The default is 128. A value of 0 means no limit. + +=item $s->format_request($method, $uri, %headers, [$content]) + +Format a request message and return it as a string. If the headers do +not include a C<Host> header, then a header is inserted with the value +of the C<host> attribute. Headers like C<Connection> and +C<Keep-Alive> might also be added depending on the status of the +C<keep_alive> attribute. + +If $content is given (and it is non-empty), then a C<Content-Length> +header is automatically added unless it was already present. + +=item $s->write_request($method, $uri, %headers, [$content]) + +Format and send a request message. Arguments are the same as for +format_request(). Returns true if successful. + +=item $s->format_chunk( $data ) + +Returns the string to be written for the given chunk of data. + +=item $s->write_chunk($data) + +Will write a new chunk of request entity body data. This method +should only be used if the C<Transfer-Encoding> header with a value of +C<chunked> was sent in the request. Note, writing zero-length data is +a no-op. Use the write_chunk_eof() method to signal end of entity +body data. + +Returns true if successful. + +=item $s->format_chunk_eof( %trailers ) + +Returns the string to be written for signaling EOF when a +C<Transfer-Encoding> of C<chunked> is used. + +=item $s->write_chunk_eof( %trailers ) + +Will write eof marker for chunked data and optional trailers. Note +that trailers should not really be used unless is was signaled +with a C<Trailer> header. + +Returns true if successful. + +=item ($code, $mess, %headers) = $s->read_response_headers( %opts ) + +Read response headers from server and return it. The $code is the 3 +digit HTTP status code (see L<HTTP::Status>) and $mess is the textual +message that came with it. Headers are then returned as key/value +pairs. Since key letter casing is not normalized and the same key can +even occur multiple times, assigning these values directly to a hash +is not wise. Only the $code is returned if this method is called in +scalar context. + +As a side effect this method updates the 'peer_http_version' +attribute. + +Options might be passed in as key/value pairs. There are currently +only two options supported; C<laxed> and C<junk_out>. + +The C<laxed> option will make read_response_headers() more forgiving +towards servers that have not learned how to speak HTTP properly. The +C<laxed> option is a boolean flag, and is enabled by passing in a TRUE +value. The C<junk_out> option can be used to capture bad header lines +when C<laxed> is enabled. The value should be an array reference. +Bad header lines will be pushed onto the array. + +The C<laxed> option must be specified in order to communicate with +pre-HTTP/1.0 servers that don't describe the response outcome or the +data they send back with a header block. For these servers +peer_http_version is set to "0.9" and this method returns (200, +"Assumed OK"). + +The method will raise an exception (die) if the server does not speak +proper HTTP or if the C<max_line_length> or C<max_header_length> +limits are reached. If the C<laxed> option is turned on and +C<max_line_length> and C<max_header_length> checks are turned off, +then no exception will be raised and this method will always +return a response code. + +=item $n = $s->read_entity_body($buf, $size); + +Reads chunks of the entity body content. Basically the same interface +as for read() and sysread(), but the buffer offset argument is not +supported yet. This method should only be called after a successful +read_response_headers() call. + +The return value will be C<undef> on read errors, 0 on EOF, -1 if no data +could be returned this time, otherwise the number of bytes assigned +to $buf. The $buf is set to "" when the return value is -1. + +You normally want to retry this call if this function returns either +-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>). EINTR +can happen if the application catches signals and EAGAIN can happen if +you made the socket non-blocking. + +This method will raise exceptions (die) if the server does not speak +proper HTTP. This can only happen when reading chunked data. + +=item %headers = $s->get_trailers + +After read_entity_body() has returned 0 to indicate end of the entity +body, you might call this method to pick up any trailers. + +=item $s->_rbuf + +Get/set the read buffer content. The read_response_headers() and +read_entity_body() methods use an internal buffer which they will look +for data before they actually sysread more from the socket itself. If +they read too much, the remaining data will be left in this buffer. + +=item $s->_rbuf_length + +Returns the number of bytes in the read buffer. This should always be +the same as: + + length($s->_rbuf) + +but might be more efficient. + +=back + +=head1 SUBCLASSING + +The read_response_headers() and read_entity_body() will invoke the +sysread() method when they need more data. Subclasses might want to +override this method to control how reading takes place. + +The object itself is a glob. Subclasses should avoid using hash key +names prefixed with C<http_> and C<io_>. + +=head1 SEE ALSO + +L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB> + +=head1 COPYRIGHT + +Copyright 2001-2003 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/Net/HTTP/Methods.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm new file mode 100644 index 00000000000..22cc272b47e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm @@ -0,0 +1,593 @@ +package Net::HTTP::Methods; + +require 5.005; # 4-arg substr + +use strict; +use vars qw($VERSION); + +$VERSION = "5.834"; + +my $CRLF = "\015\012"; # "\r\n" is not portable + +*_bytes = defined(&utf8::downgrade) ? + sub { + unless (utf8::downgrade($_[0], 1)) { + require Carp; + Carp::croak("Wide character in HTTP request (bytes required)"); + } + return $_[0]; + } + : + sub { + return $_[0]; + }; + + +sub new { + my $class = shift; + unshift(@_, "Host") if @_ == 1; + my %cnf = @_; + require Symbol; + my $self = bless Symbol::gensym(), $class; + return $self->http_configure(\%cnf); +} + +sub http_configure { + my($self, $cnf) = @_; + + die "Listen option not allowed" if $cnf->{Listen}; + my $explict_host = (exists $cnf->{Host}); + my $host = delete $cnf->{Host}; + my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost}; + if (!$peer) { + die "No Host option provided" unless $host; + $cnf->{PeerAddr} = $peer = $host; + } + + if ($peer =~ s,:(\d+)$,,) { + $cnf->{PeerPort} = int($1); # always override + } + if (!$cnf->{PeerPort}) { + $cnf->{PeerPort} = $self->http_default_port; + } + + if (!$explict_host) { + $host = $peer; + $host =~ s/:.*//; + } + if ($host && $host !~ /:/) { + my $p = $cnf->{PeerPort}; + $host .= ":$p" if $p != $self->http_default_port; + } + + $cnf->{Proto} = 'tcp'; + + my $keep_alive = delete $cnf->{KeepAlive}; + my $http_version = delete $cnf->{HTTPVersion}; + $http_version = "1.1" unless defined $http_version; + my $peer_http_version = delete $cnf->{PeerHTTPVersion}; + $peer_http_version = "1.0" unless defined $peer_http_version; + my $send_te = delete $cnf->{SendTE}; + my $max_line_length = delete $cnf->{MaxLineLength}; + $max_line_length = 8*1024 unless defined $max_line_length; + my $max_header_lines = delete $cnf->{MaxHeaderLines}; + $max_header_lines = 128 unless defined $max_header_lines; + + return undef unless $self->http_connect($cnf); + + $self->host($host); + $self->keep_alive($keep_alive); + $self->send_te($send_te); + $self->http_version($http_version); + $self->peer_http_version($peer_http_version); + $self->max_line_length($max_line_length); + $self->max_header_lines($max_header_lines); + + ${*$self}{'http_buf'} = ""; + + return $self; +} + +sub http_default_port { + 80; +} + +# set up property accessors +for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) { + my $prop_name = "http_" . $method; + no strict 'refs'; + *$method = sub { + my $self = shift; + my $old = ${*$self}{$prop_name}; + ${*$self}{$prop_name} = shift if @_; + return $old; + }; +} + +# we want this one to be a bit smarter +sub http_version { + my $self = shift; + my $old = ${*$self}{'http_version'}; + if (@_) { + my $v = shift; + $v = "1.0" if $v eq "1"; # float + unless ($v eq "1.0" or $v eq "1.1") { + require Carp; + Carp::croak("Unsupported HTTP version '$v'"); + } + ${*$self}{'http_version'} = $v; + } + $old; +} + +sub format_request { + my $self = shift; + my $method = shift; + my $uri = shift; + + my $content = (@_ % 2) ? pop : ""; + + for ($method, $uri) { + require Carp; + Carp::croak("Bad method or uri") if /\s/ || !length; + } + + push(@{${*$self}{'http_request_method'}}, $method); + my $ver = ${*$self}{'http_version'}; + my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0"; + + my @h; + my @connection; + my %given = (host => 0, "content-length" => 0, "te" => 0); + while (@_) { + my($k, $v) = splice(@_, 0, 2); + my $lc_k = lc($k); + if ($lc_k eq "connection") { + $v =~ s/^\s+//; + $v =~ s/\s+$//; + push(@connection, split(/\s*,\s*/, $v)); + next; + } + if (exists $given{$lc_k}) { + $given{$lc_k}++; + } + push(@h, "$k: $v"); + } + + if (length($content) && !$given{'content-length'}) { + push(@h, "Content-Length: " . length($content)); + } + + my @h2; + if ($given{te}) { + push(@connection, "TE") unless grep lc($_) eq "te", @connection; + } + elsif ($self->send_te && gunzip_ok()) { + # gzip is less wanted since the IO::Uncompress::Gunzip interface for + # it does not really allow chunked decoding to take place easily. + push(@h2, "TE: deflate,gzip;q=0.3"); + push(@connection, "TE"); + } + + unless (grep lc($_) eq "close", @connection) { + if ($self->keep_alive) { + if ($peer_ver eq "1.0") { + # from looking at Netscape's headers + push(@h2, "Keep-Alive: 300"); + unshift(@connection, "Keep-Alive"); + } + } + else { + push(@connection, "close") if $ver ge "1.1"; + } + } + push(@h2, "Connection: " . join(", ", @connection)) if @connection; + unless ($given{host}) { + my $h = ${*$self}{'http_host'}; + push(@h2, "Host: $h") if $h; + } + + return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content)); +} + + +sub write_request { + my $self = shift; + $self->print($self->format_request(@_)); +} + +sub format_chunk { + my $self = shift; + return $_[0] unless defined($_[0]) && length($_[0]); + return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF); +} + +sub write_chunk { + my $self = shift; + return 1 unless defined($_[0]) && length($_[0]); + $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF)); +} + +sub format_chunk_eof { + my $self = shift; + my @h; + while (@_) { + push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2)); + } + return _bytes(join("", "0$CRLF", @h, $CRLF)); +} + +sub write_chunk_eof { + my $self = shift; + $self->print($self->format_chunk_eof(@_)); +} + + +sub my_read { + die if @_ > 3; + my $self = shift; + my $len = $_[1]; + for (${*$self}{'http_buf'}) { + if (length) { + $_[0] = substr($_, 0, $len, ""); + return length($_[0]); + } + else { + return $self->sysread($_[0], $len); + } + } +} + + +sub my_readline { + my $self = shift; + my $what = shift; + for (${*$self}{'http_buf'}) { + my $max_line_length = ${*$self}{'http_max_line_length'}; + my $pos; + while (1) { + # find line ending + $pos = index($_, "\012"); + last if $pos >= 0; + die "$what line too long (limit is $max_line_length)" + if $max_line_length && length($_) > $max_line_length; + + # need to read more data to find a line ending + READ: + { + my $n = $self->sysread($_, 1024, length); + unless (defined $n) { + redo READ if $!{EINTR}; + if ($!{EAGAIN}) { + # Hmm, we must be reading from a non-blocking socket + # XXX Should really wait until this socket is readable,... + select(undef, undef, undef, 0.1); # but this will do for now + redo READ; + } + # if we have already accumulated some data let's at least + # return that as a line + die "$what read failed: $!" unless length; + } + unless ($n) { + return undef unless length; + return substr($_, 0, length, ""); + } + } + } + die "$what line too long ($pos; limit is $max_line_length)" + if $max_line_length && $pos > $max_line_length; + + my $line = substr($_, 0, $pos+1, ""); + $line =~ s/(\015?\012)\z// || die "Assert"; + return wantarray ? ($line, $1) : $line; + } +} + + +sub _rbuf { + my $self = shift; + if (@_) { + for (${*$self}{'http_buf'}) { + my $old; + $old = $_ if defined wantarray; + $_ = shift; + return $old; + } + } + else { + return ${*$self}{'http_buf'}; + } +} + +sub _rbuf_length { + my $self = shift; + return length ${*$self}{'http_buf'}; +} + + +sub _read_header_lines { + my $self = shift; + my $junk_out = shift; + + my @headers; + my $line_count = 0; + my $max_header_lines = ${*$self}{'http_max_header_lines'}; + while (my $line = my_readline($self, 'Header')) { + if ($line =~ /^(\S+?)\s*:\s*(.*)/s) { + push(@headers, $1, $2); + } + elsif (@headers && $line =~ s/^\s+//) { + $headers[-1] .= " " . $line; + } + elsif ($junk_out) { + push(@$junk_out, $line); + } + else { + die "Bad header: '$line'\n"; + } + if ($max_header_lines) { + $line_count++; + if ($line_count >= $max_header_lines) { + die "Too many header lines (limit is $max_header_lines)"; + } + } + } + return @headers; +} + + +sub read_response_headers { + my($self, %opt) = @_; + my $laxed = $opt{laxed}; + + my($status, $eol) = my_readline($self, 'Status'); + unless (defined $status) { + die "Server closed connection without sending any data back"; + } + + my($peer_ver, $code, $message) = split(/\s+/, $status, 3); + if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) { + die "Bad response status line: '$status'" unless $laxed; + # assume HTTP/0.9 + ${*$self}{'http_peer_http_version'} = "0.9"; + ${*$self}{'http_status'} = "200"; + substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || ""); + return 200 unless wantarray; + return (200, "Assumed OK"); + }; + + ${*$self}{'http_peer_http_version'} = $peer_ver; + ${*$self}{'http_status'} = $code; + + my $junk_out; + if ($laxed) { + $junk_out = $opt{junk_out} || []; + } + my @headers = $self->_read_header_lines($junk_out); + + # pick out headers that read_entity_body might need + my @te; + my $content_length; + for (my $i = 0; $i < @headers; $i += 2) { + my $h = lc($headers[$i]); + if ($h eq 'transfer-encoding') { + my $te = $headers[$i+1]; + $te =~ s/^\s+//; + $te =~ s/\s+$//; + push(@te, $te) if length($te); + } + elsif ($h eq 'content-length') { + # ignore bogus and overflow values + if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) { + $content_length = $1; + } + } + } + ${*$self}{'http_te'} = join(",", @te); + ${*$self}{'http_content_length'} = $content_length; + ${*$self}{'http_first_body'}++; + delete ${*$self}{'http_trailers'}; + return $code unless wantarray; + return ($code, $message, @headers); +} + + +sub read_entity_body { + my $self = shift; + my $buf_ref = \$_[0]; + my $size = $_[1]; + die "Offset not supported yet" if $_[2]; + + my $chunked; + my $bytes; + + if (${*$self}{'http_first_body'}) { + ${*$self}{'http_first_body'} = 0; + delete ${*$self}{'http_chunked'}; + delete ${*$self}{'http_bytes'}; + my $method = shift(@{${*$self}{'http_request_method'}}); + my $status = ${*$self}{'http_status'}; + if ($method eq "HEAD") { + # this response is always empty regardless of other headers + $bytes = 0; + } + elsif (my $te = ${*$self}{'http_te'}) { + my @te = split(/\s*,\s*/, lc($te)); + die "Chunked must be last Transfer-Encoding '$te'" + unless pop(@te) eq "chunked"; + + for (@te) { + if ($_ eq "deflate" && inflate_ok()) { + #require Compress::Raw::Zlib; + my ($i, $status) = Compress::Raw::Zlib::Inflate->new(); + die "Can't make inflator: $status" unless $i; + $_ = sub { my $out; $i->inflate($_[0], \$out); $out } + } + elsif ($_ eq "gzip" && gunzip_ok()) { + #require IO::Uncompress::Gunzip; + my @buf; + $_ = sub { + push(@buf, $_[0]); + return "" unless $_[1]; + my $input = join("", @buf); + my $output; + IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0) + or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; + return \$output; + }; + } + elsif ($_ eq "identity") { + $_ = sub { $_[0] }; + } + else { + die "Can't handle transfer encoding '$te'"; + } + } + + @te = reverse(@te); + + ${*$self}{'http_te2'} = @te ? \@te : ""; + $chunked = -1; + } + elsif (defined(my $content_length = ${*$self}{'http_content_length'})) { + $bytes = $content_length; + } + elsif ($status =~ /^(?:1|[23]04)/) { + # RFC 2616 says that these responses should always be empty + # but that does not appear to be true in practice [RT#17907] + $bytes = 0; + } + else { + # XXX Multi-Part types are self delimiting, but RFC 2616 says we + # only has to deal with 'multipart/byteranges' + + # Read until EOF + } + } + else { + $chunked = ${*$self}{'http_chunked'}; + $bytes = ${*$self}{'http_bytes'}; + } + + if (defined $chunked) { + # The state encoded in $chunked is: + # $chunked == 0: read CRLF after chunk, then chunk header + # $chunked == -1: read chunk header + # $chunked > 0: bytes left in current chunk to read + + if ($chunked <= 0) { + my $line = my_readline($self, 'Entity body'); + if ($chunked == 0) { + die "Missing newline after chunk data: '$line'" + if !defined($line) || $line ne ""; + $line = my_readline($self, 'Entity body'); + } + die "EOF when chunk header expected" unless defined($line); + my $chunk_len = $line; + $chunk_len =~ s/;.*//; # ignore potential chunk parameters + unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) { + die "Bad chunk-size in HTTP response: $line"; + } + $chunked = hex($1); + if ($chunked == 0) { + ${*$self}{'http_trailers'} = [$self->_read_header_lines]; + $$buf_ref = ""; + + my $n = 0; + if (my $transforms = delete ${*$self}{'http_te2'}) { + for (@$transforms) { + $$buf_ref = &$_($$buf_ref, 1); + } + $n = length($$buf_ref); + } + + # in case somebody tries to read more, make sure we continue + # to return EOF + delete ${*$self}{'http_chunked'}; + ${*$self}{'http_bytes'} = 0; + + return $n; + } + } + + my $n = $chunked; + $n = $size if $size && $size < $n; + $n = my_read($self, $$buf_ref, $n); + return undef unless defined $n; + + ${*$self}{'http_chunked'} = $chunked - $n; + + if ($n > 0) { + if (my $transforms = ${*$self}{'http_te2'}) { + for (@$transforms) { + $$buf_ref = &$_($$buf_ref, 0); + } + $n = length($$buf_ref); + $n = -1 if $n == 0; + } + } + return $n; + } + elsif (defined $bytes) { + unless ($bytes) { + $$buf_ref = ""; + return 0; + } + my $n = $bytes; + $n = $size if $size && $size < $n; + $n = my_read($self, $$buf_ref, $n); + return undef unless defined $n; + ${*$self}{'http_bytes'} = $bytes - $n; + return $n; + } + else { + # read until eof + $size ||= 8*1024; + return my_read($self, $$buf_ref, $size); + } +} + +sub get_trailers { + my $self = shift; + @{${*$self}{'http_trailers'} || []}; +} + +BEGIN { +my $gunzip_ok; +my $inflate_ok; + +sub gunzip_ok { + return $gunzip_ok if defined $gunzip_ok; + + # Try to load IO::Uncompress::Gunzip. + local $@; + local $SIG{__DIE__}; + $gunzip_ok = 0; + + eval { + require IO::Uncompress::Gunzip; + $gunzip_ok++; + }; + + return $gunzip_ok; +} + +sub inflate_ok { + return $inflate_ok if defined $inflate_ok; + + # Try to load Compress::Raw::Zlib. + local $@; + local $SIG{__DIE__}; + $inflate_ok = 0; + + eval { + require Compress::Raw::Zlib; + $inflate_ok++; + }; + + return $inflate_ok; +} + +} # BEGIN + +1; diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm new file mode 100644 index 00000000000..e4145116f6a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm @@ -0,0 +1,105 @@ +package Net::HTTP::NB; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "5.810"; + +require Net::HTTP; +@ISA=qw(Net::HTTP); + +sub sysread { + my $self = $_[0]; + if (${*$self}{'httpnb_read_count'}++) { + ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'}; + die "Multi-read\n"; + } + my $buf; + my $offset = $_[3] || 0; + my $n = sysread($self, $_[1], $_[2], $offset); + ${*$self}{'httpnb_save'} .= substr($_[1], $offset); + return $n; +} + +sub read_response_headers { + my $self = shift; + ${*$self}{'httpnb_read_count'} = 0; + ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; + my @h = eval { $self->SUPER::read_response_headers(@_) }; + if ($@) { + return if $@ eq "Multi-read\n"; + die; + } + return @h; +} + +sub read_entity_body { + my $self = shift; + ${*$self}{'httpnb_read_count'} = 0; + ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; + # XXX I'm not so sure this does the correct thing in case of + # transfer-encoding tranforms + my $n = eval { $self->SUPER::read_entity_body(@_); }; + if ($@) { + $_[0] = ""; + return -1; + } + return $n; +} + +1; + +__END__ + +=head1 NAME + +Net::HTTP::NB - Non-blocking HTTP client + +=head1 SYNOPSIS + + use Net::HTTP::NB; + my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@; + $s->write_request(GET => "/"); + + use IO::Select; + my $sel = IO::Select->new($s); + + READ_HEADER: { + die "Header timeout" unless $sel->can_read(10); + my($code, $mess, %h) = $s->read_response_headers; + redo READ_HEADER unless $code; + } + + while (1) { + die "Body timeout" unless $sel->can_read(10); + my $buf; + my $n = $s->read_entity_body($buf, 1024); + last unless $n; + print $buf; + } + +=head1 DESCRIPTION + +Same interface as C<Net::HTTP> but it will never try multiple reads +when the read_response_headers() or read_entity_body() methods are +invoked. This make it possible to multiplex multiple Net::HTTP::NB +using select without risk blocking. + +If read_response_headers() did not see enough data to complete the +headers an empty list is returned. + +If read_entity_body() did not see new entity data in its read +the value -1 is returned. + +=head1 SEE ALSO + +L<Net::HTTP> + +=head1 COPYRIGHT + +Copyright 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/Net/HTTPS.pm b/Master/tlpkg/tlperl/lib/Net/HTTPS.pm new file mode 100644 index 00000000000..bfed714870c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Net/HTTPS.pm @@ -0,0 +1,59 @@ +package Net::HTTPS; + +use strict; +use vars qw($VERSION $SSL_SOCKET_CLASS @ISA); + +$VERSION = "5.819"; + +# Figure out which SSL implementation to use +if ($SSL_SOCKET_CLASS) { + # somebody already set it +} +elsif ($Net::SSL::VERSION) { + $SSL_SOCKET_CLASS = "Net::SSL"; +} +elsif ($IO::Socket::SSL::VERSION) { + $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded +} +else { + eval { require Net::SSL; }; # from Crypt-SSLeay + if ($@) { + my $old_errsv = $@; + eval { + require IO::Socket::SSL; + }; + if ($@) { + $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g; + die $old_errsv . $@; + } + $SSL_SOCKET_CLASS = "IO::Socket::SSL"; + } + else { + $SSL_SOCKET_CLASS = "Net::SSL"; + } +} + +require Net::HTTP::Methods; + +@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods'); + +sub configure { + my($self, $cnf) = @_; + $self->http_configure($cnf); +} + +sub http_connect { + my($self, $cnf) = @_; + $self->SUPER::configure($cnf); +} + +sub http_default_port { + 443; +} + +# The underlying SSLeay classes fails to work if the socket is +# placed in non-blocking mode. This override of the blocking +# method makes sure it stays the way it was created. +sub blocking { } # noop + +1; diff --git a/Master/tlpkg/tlperl/lib/URI.pm b/Master/tlpkg/tlperl/lib/URI.pm new file mode 100644 index 00000000000..c0285a7097c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI.pm @@ -0,0 +1,1109 @@ +package URI; + +use strict; +use vars qw($VERSION); +$VERSION = "1.58"; + +use vars qw($ABS_REMOTE_LEADING_DOTS $ABS_ALLOW_RELATIVE_SCHEME $DEFAULT_QUERY_FORM_DELIMITER); + +my %implements; # mapping from scheme to implementor class + +# Some "official" character classes + +use vars qw($reserved $mark $unreserved $uric $scheme_re); +$reserved = q(;/?:@&=+$,[]); +$mark = q(-_.!~*'()); #'; emacs +$unreserved = "A-Za-z0-9\Q$mark\E"; +$uric = quotemeta($reserved) . $unreserved . "%"; + +$scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*'; + +use Carp (); +use URI::Escape (); + +use overload ('""' => sub { ${$_[0]} }, + '==' => sub { _obj_eq(@_) }, + '!=' => sub { !_obj_eq(@_) }, + fallback => 1, + ); + +# Check if two objects are the same object +sub _obj_eq { + return overload::StrVal($_[0]) eq overload::StrVal($_[1]); +} + +sub new +{ + my($class, $uri, $scheme) = @_; + + $uri = defined ($uri) ? "$uri" : ""; # stringify + # Get rid of potential wrapping + $uri =~ s/^<(?:URL:)?(.*)>$/$1/; # + $uri =~ s/^"(.*)"$/$1/; + $uri =~ s/^\s+//; + $uri =~ s/\s+$//; + + my $impclass; + if ($uri =~ m/^($scheme_re):/so) { + $scheme = $1; + } + else { + if (($impclass = ref($scheme))) { + $scheme = $scheme->scheme; + } + elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) { + $scheme = $1; + } + } + $impclass ||= implementor($scheme) || + do { + require URI::_foreign; + $impclass = 'URI::_foreign'; + }; + + return $impclass->_init($uri, $scheme); +} + + +sub new_abs +{ + my($class, $uri, $base) = @_; + $uri = $class->new($uri, $base); + $uri->abs($base); +} + + +sub _init +{ + my $class = shift; + my($str, $scheme) = @_; + # find all funny characters and encode the bytes. + $str = $class->_uric_escape($str); + $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o || + $class->_no_scheme_ok; + my $self = bless \$str, $class; + $self; +} + + +sub _uric_escape +{ + my($class, $str) = @_; + $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego; + return $str; +} + + +sub implementor +{ + my($scheme, $impclass) = @_; + if (!$scheme || $scheme !~ /\A$scheme_re\z/o) { + require URI::_generic; + return "URI::_generic"; + } + + $scheme = lc($scheme); + + if ($impclass) { + # Set the implementor class for a given scheme + my $old = $implements{$scheme}; + $impclass->_init_implementor($scheme); + $implements{$scheme} = $impclass; + return $old; + } + + my $ic = $implements{$scheme}; + return $ic if $ic; + + # scheme not yet known, look for internal or + # preloaded (with 'use') implementation + $ic = "URI::$scheme"; # default location + + # turn scheme into a valid perl identifier by a simple transformation... + $ic =~ s/\+/_P/g; + $ic =~ s/\./_O/g; + $ic =~ s/\-/_/g; + + no strict 'refs'; + # check we actually have one for the scheme: + unless (@{"${ic}::ISA"}) { + # Try to load it + eval "require $ic"; + die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; + return unless @{"${ic}::ISA"}; + } + + $ic->_init_implementor($scheme); + $implements{$scheme} = $ic; + $ic; +} + + +sub _init_implementor +{ + my($class, $scheme) = @_; + # Remember that one implementor class may actually + # serve to implement several URI schemes. +} + + +sub clone +{ + my $self = shift; + my $other = $$self; + bless \$other, ref $self; +} + + +sub _no_scheme_ok { 0 } + +sub _scheme +{ + my $self = shift; + + unless (@_) { + return unless $$self =~ /^($scheme_re):/o; + return $1; + } + + my $old; + my $new = shift; + if (defined($new) && length($new)) { + Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o; + $old = $1 if $$self =~ s/^($scheme_re)://o; + my $newself = URI->new("$new:$$self"); + $$self = $$newself; + bless $self, ref($newself); + } + else { + if ($self->_no_scheme_ok) { + $old = $1 if $$self =~ s/^($scheme_re)://o; + Carp::carp("Oops, opaque part now look like scheme") + if $^W && $$self =~ m/^$scheme_re:/o + } + else { + $old = $1 if $$self =~ m/^($scheme_re):/o; + } + } + + return $old; +} + +sub scheme +{ + my $scheme = shift->_scheme(@_); + return unless defined $scheme; + lc($scheme); +} + + +sub opaque +{ + my $self = shift; + + unless (@_) { + $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die; + return $1; + } + + $$self =~ /^($scheme_re:)? # optional scheme + ([^\#]*) # opaque + (\#.*)? # optional fragment + $/sx or die; + + my $old_scheme = $1; + my $old_opaque = $2; + my $old_frag = $3; + + my $new_opaque = shift; + $new_opaque = "" unless defined $new_opaque; + $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego; + + $$self = defined($old_scheme) ? $old_scheme : ""; + $$self .= $new_opaque; + $$self .= $old_frag if defined $old_frag; + + $old_opaque; +} + +*path = \&opaque; # alias + + +sub fragment +{ + my $self = shift; + unless (@_) { + return unless $$self =~ /\#(.*)/s; + return $1; + } + + my $old; + $old = $1 if $$self =~ s/\#(.*)//s; + + my $new_frag = shift; + if (defined $new_frag) { + $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego; + $$self .= "#$new_frag"; + } + $old; +} + + +sub as_string +{ + my $self = shift; + $$self; +} + + +sub as_iri +{ + my $self = shift; + my $str = $$self; + if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) { + # All this crap because the more obvious: + # + # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift }) + # + # doesn't work before Encode 2.39. Wait for a standard release + # to bundle that version. + + require Encode; + my $enc = Encode::find_encoding("UTF-8"); + my $u = ""; + while (length $str) { + $u .= $enc->decode($str, Encode::FB_QUIET()); + if (length $str) { + # escape next char + $u .= URI::Escape::escape_char(substr($str, 0, 1, "")); + } + } + $str = $u; + } + return $str; +} + + +sub canonical +{ + # Make sure scheme is lowercased, that we don't escape unreserved chars, + # and that we use upcase escape sequences. + + my $self = shift; + my $scheme = $self->_scheme || ""; + my $uc_scheme = $scheme =~ /[A-Z]/; + my $esc = $$self =~ /%[a-fA-F0-9]{2}/; + return $self unless $uc_scheme || $esc; + + my $other = $self->clone; + if ($uc_scheme) { + $other->_scheme(lc $scheme); + } + if ($esc) { + $$other =~ s{%([0-9a-fA-F]{2})} + { my $a = chr(hex($1)); + $a =~ /^[$unreserved]\z/o ? $a : "%\U$1" + }ge; + } + return $other; +} + +# Compare two URIs, subclasses will provide a more correct implementation +sub eq { + my($self, $other) = @_; + $self = URI->new($self, $other) unless ref $self; + $other = URI->new($other, $self) unless ref $other; + ref($self) eq ref($other) && # same class + $self->canonical->as_string eq $other->canonical->as_string; +} + +# generic-URI transformation methods +sub abs { $_[0]; } +sub rel { $_[0]; } + +sub secure { 0 } + +# help out Storable +sub STORABLE_freeze { + my($self, $cloning) = @_; + return $$self; +} + +sub STORABLE_thaw { + my($self, $cloning, $str) = @_; + $$self = $str; +} + +1; + +__END__ + +=head1 NAME + +URI - Uniform Resource Identifiers (absolute and relative) + +=head1 SYNOPSIS + + $u1 = URI->new("http://www.perl.com"); + $u2 = URI->new("foo", "http"); + $u3 = $u2->abs($u1); + $u4 = $u3->clone; + $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical; + + $str = $u->as_string; + $str = "$u"; + + $scheme = $u->scheme; + $opaque = $u->opaque; + $path = $u->path; + $frag = $u->fragment; + + $u->scheme("ftp"); + $u->host("ftp.perl.com"); + $u->path("cpan/"); + +=head1 DESCRIPTION + +This module implements the C<URI> class. Objects of this class +represent "Uniform Resource Identifier references" as specified in RFC +2396 (and updated by RFC 2732). + +A Uniform Resource Identifier is a compact string of characters that +identifies an abstract or physical resource. A Uniform Resource +Identifier can be further classified as either a Uniform Resource Locator +(URL) or a Uniform Resource Name (URN). The distinction between URL +and URN does not matter to the C<URI> class interface. A +"URI-reference" is a URI that may have additional information attached +in the form of a fragment identifier. + +An absolute URI reference consists of three parts: a I<scheme>, a +I<scheme-specific part> and a I<fragment> identifier. A subset of URI +references share a common syntax for hierarchical namespaces. For +these, the scheme-specific part is further broken down into +I<authority>, I<path> and I<query> components. These URIs can also +take the form of relative URI references, where the scheme (and +usually also the authority) component is missing, but implied by the +context of the URI reference. The three forms of URI reference +syntax are summarized as follows: + + <scheme>:<scheme-specific-part>#<fragment> + <scheme>://<authority><path>?<query>#<fragment> + <path>?<query>#<fragment> + +The components into which a URI reference can be divided depend on the +I<scheme>. The C<URI> class provides methods to get and set the +individual components. The methods available for a specific +C<URI> object depend on the scheme. + +=head1 CONSTRUCTORS + +The following methods construct new C<URI> objects: + +=over 4 + +=item $uri = URI->new( $str ) + +=item $uri = URI->new( $str, $scheme ) + +Constructs a new URI object. The string +representation of a URI is given as argument, together with an optional +scheme specification. Common URI wrappers like "" and <>, as well as +leading and trailing white space, are automatically removed from +the $str argument before it is processed further. + +The constructor determines the scheme, maps this to an appropriate +URI subclass, constructs a new object of that class and returns it. + +The $scheme argument is only used when $str is a +relative URI. It can be either a simple string that +denotes the scheme, a string containing an absolute URI reference, or +an absolute C<URI> object. If no $scheme is specified for a relative +URI $str, then $str is simply treated as a generic URI (no scheme-specific +methods available). + +The set of characters available for building URI references is +restricted (see L<URI::Escape>). Characters outside this set are +automatically escaped by the URI constructor. + +=item $uri = URI->new_abs( $str, $base_uri ) + +Constructs a new absolute URI object. The $str argument can +denote a relative or absolute URI. If relative, then it is +absolutized using $base_uri as base. The $base_uri must be an absolute +URI. + +=item $uri = URI::file->new( $filename ) + +=item $uri = URI::file->new( $filename, $os ) + +Constructs a new I<file> URI from a file name. See L<URI::file>. + +=item $uri = URI::file->new_abs( $filename ) + +=item $uri = URI::file->new_abs( $filename, $os ) + +Constructs a new absolute I<file> URI from a file name. See +L<URI::file>. + +=item $uri = URI::file->cwd + +Returns the current working directory as a I<file> URI. See +L<URI::file>. + +=item $uri->clone + +Returns a copy of the $uri. + +=back + +=head1 COMMON METHODS + +The methods described in this section are available for all C<URI> +objects. + +Methods that give access to components of a URI always return the +old value of the component. The value returned is C<undef> if the +component was not present. There is generally a difference between a +component that is empty (represented as C<"">) and a component that is +missing (represented as C<undef>). If an accessor method is given an +argument, it updates the corresponding component in addition to +returning the old value of the component. Passing an undefined +argument removes the component (if possible). The description of +each accessor method indicates whether the component is passed as +an escaped or an unescaped string. A component that can be further +divided into sub-parts are usually passed escaped, as unescaping might +change its semantics. + +The common methods available for all URI are: + +=over 4 + +=item $uri->scheme + +=item $uri->scheme( $new_scheme ) + +Sets and returns the scheme part of the $uri. If the $uri is +relative, then $uri->scheme returns C<undef>. If called with an +argument, it updates the scheme of $uri, possibly changing the +class of $uri, and returns the old scheme value. The method croaks +if the new scheme name is illegal; a scheme name must begin with a +letter and must consist of only US-ASCII letters, numbers, and a few +special marks: ".", "+", "-". This restriction effectively means +that the scheme must be passed unescaped. Passing an undefined +argument to the scheme method makes the URI relative (if possible). + +Letter case does not matter for scheme names. The string +returned by $uri->scheme is always lowercase. If you want the scheme +just as it was written in the URI in its original case, +you can use the $uri->_scheme method instead. + +=item $uri->opaque + +=item $uri->opaque( $new_opaque ) + +Sets and returns the scheme-specific part of the $uri +(everything between the scheme and the fragment) +as an escaped string. + +=item $uri->path + +=item $uri->path( $new_path ) + +Sets and returns the same value as $uri->opaque unless the URI +supports the generic syntax for hierarchical namespaces. +In that case the generic method is overridden to set and return +the part of the URI between the I<host name> and the I<fragment>. + +=item $uri->fragment + +=item $uri->fragment( $new_frag ) + +Returns the fragment identifier of a URI reference +as an escaped string. + +=item $uri->as_string + +Returns a URI object to a plain ASCII string. URI objects are +also converted to plain strings automatically by overloading. This +means that $uri objects can be used as plain strings in most Perl +constructs. + +=item $uri->as_iri + +Returns a Unicode string representing the URI. Escaped UTF-8 sequences +representing non-ASCII characters are turned into their corresponding Unicode +code point. + +=item $uri->canonical + +Returns a normalized version of the URI. The rules +for normalization are scheme-dependent. They usually involve +lowercasing the scheme and Internet host name components, +removing the explicit port specification if it matches the default port, +uppercasing all escape sequences, and unescaping octets that can be +better represented as plain characters. + +For efficiency reasons, if the $uri is already in normalized form, +then a reference to it is returned instead of a copy. + +=item $uri->eq( $other_uri ) + +=item URI::eq( $first_uri, $other_uri ) + +Tests whether two URI references are equal. URI references +that normalize to the same string are considered equal. The method +can also be used as a plain function which can also test two string +arguments. + +If you need to test whether two C<URI> object references denote the +same object, use the '==' operator. + +=item $uri->abs( $base_uri ) + +Returns an absolute URI reference. If $uri is already +absolute, then a reference to it is simply returned. If the $uri +is relative, then a new absolute URI is constructed by combining the +$uri and the $base_uri, and returned. + +=item $uri->rel( $base_uri ) + +Returns a relative URI reference if it is possible to +make one that denotes the same resource relative to $base_uri. +If not, then $uri is simply returned. + +=item $uri->secure + +Returns a TRUE value if the URI is considered to point to a resource on +a secure channel, such as an SSL or TLS encrypted one. + +=back + +=head1 GENERIC METHODS + +The following methods are available to schemes that use the +common/generic syntax for hierarchical namespaces. The descriptions of +schemes below indicate which these are. Unknown schemes are +assumed to support the generic syntax, and therefore the following +methods: + +=over 4 + +=item $uri->authority + +=item $uri->authority( $new_authority ) + +Sets and returns the escaped authority component +of the $uri. + +=item $uri->path + +=item $uri->path( $new_path ) + +Sets and returns the escaped path component of +the $uri (the part between the host name and the query or fragment). +The path can never be undefined, but it can be the empty string. + +=item $uri->path_query + +=item $uri->path_query( $new_path_query ) + +Sets and returns the escaped path and query +components as a single entity. The path and the query are +separated by a "?" character, but the query can itself contain "?". + +=item $uri->path_segments + +=item $uri->path_segments( $segment, ... ) + +Sets and returns the path. In a scalar context, it returns +the same value as $uri->path. In a list context, it returns the +unescaped path segments that make up the path. Path segments that +have parameters are returned as an anonymous array. The first element +is the unescaped path segment proper; subsequent elements are escaped +parameter strings. Such an anonymous array uses overloading so it can +be treated as a string too, but this string does not include the +parameters. + +Note that absolute paths have the empty string as their first +I<path_segment>, i.e. the I<path> C</foo/bar> have 3 +I<path_segments>; "", "foo" and "bar". + +=item $uri->query + +=item $uri->query( $new_query ) + +Sets and returns the escaped query component of +the $uri. + +=item $uri->query_form + +=item $uri->query_form( $key1 => $val1, $key2 => $val2, ... ) + +=item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim ) + +=item $uri->query_form( \@key_value_pairs ) + +=item $uri->query_form( \@key_value_pairs, $delim ) + +=item $uri->query_form( \%hash ) + +=item $uri->query_form( \%hash, $delim ) + +Sets and returns query components that use the +I<application/x-www-form-urlencoded> format. Key/value pairs are +separated by "&", and the key is separated from the value by a "=" +character. + +The form can be set either by passing separate key/value pairs, or via +an array or hash reference. Passing an empty array or an empty hash +removes the query component, whereas passing no arguments at all leaves +the component unchanged. The order of keys is undefined if a hash +reference is passed. The old value is always returned as a list of +separate key/value pairs. Assigning this list to a hash is unwise as +the keys returned might repeat. + +The values passed when setting the form can be plain strings or +references to arrays of strings. Passing an array of values has the +same effect as passing the key repeatedly with one value at a time. +All the following statements have the same effect: + + $uri->query_form(foo => 1, foo => 2); + $uri->query_form(foo => [1, 2]); + $uri->query_form([ foo => 1, foo => 2 ]); + $uri->query_form([ foo => [1, 2] ]); + $uri->query_form({ foo => [1, 2] }); + +The $delim parameter can be passed as ";" to force the key/value pairs +to be delimited by ";" instead of "&" in the query string. This +practice is often recommended for URLs embedded in HTML or XML +documents as this avoids the trouble of escaping the "&" character. +You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to +";" for the same global effect. + +The C<URI::QueryParam> module can be loaded to add further methods to +manipulate the form of a URI. See L<URI::QueryParam> for details. + +=item $uri->query_keywords + +=item $uri->query_keywords( $keywords, ... ) + +=item $uri->query_keywords( \@keywords ) + +Sets and returns query components that use the +keywords separated by "+" format. + +The keywords can be set either by passing separate keywords directly +or by passing a reference to an array of keywords. Passing an empty +array removes the query component, whereas passing no arguments at +all leaves the component unchanged. The old value is always returned +as a list of separate words. + +=back + +=head1 SERVER METHODS + +For schemes where the I<authority> component denotes an Internet host, +the following methods are available in addition to the generic +methods. + +=over 4 + +=item $uri->userinfo + +=item $uri->userinfo( $new_userinfo ) + +Sets and returns the escaped userinfo part of the +authority component. + +For some schemes this is a user name and a password separated by +a colon. This practice is not recommended. Embedding passwords in +clear text (such as URI) has proven to be a security risk in almost +every case where it has been used. + +=item $uri->host + +=item $uri->host( $new_host ) + +Sets and returns the unescaped hostname. + +If the $new_host string ends with a colon and a number, then this +number also sets the port. + +For IPv6 addresses the brackets around the raw address is removed in the return +value from $uri->host. When setting the host attribute to an IPv6 address you +can use a raw address or one enclosed in brackets. The address needs to be +enclosed in brackets if you want to pass in a new port value as well. + +=item $uri->ihost + +Returns the host in Unicode form. Any IDNA A-labels are turned into U-labels. + +=item $uri->port + +=item $uri->port( $new_port ) + +Sets and returns the port. The port is a simple integer +that should be greater than 0. + +If a port is not specified explicitly in the URI, then the URI scheme's default port +is returned. If you don't want the default port +substituted, then you can use the $uri->_port method instead. + +=item $uri->host_port + +=item $uri->host_port( $new_host_port ) + +Sets and returns the host and port as a single +unit. The returned value includes a port, even if it matches the +default port. The host part and the port part are separated by a +colon: ":". + +For IPv6 addresses the bracketing is preserved; thus +URI->new("http://[::1]/")->host_port returns "[::1]:80". Contrast this with +$uri->host which will remove the brackets. + +=item $uri->default_port + +Returns the default port of the URI scheme to which $uri +belongs. For I<http> this is the number 80, for I<ftp> this +is the number 21, etc. The default port for a scheme can not be +changed. + +=back + +=head1 SCHEME-SPECIFIC SUPPORT + +Scheme-specific support is provided for the following URI schemes. For C<URI> +objects that do not belong to one of these, you can only use the common and +generic methods. + +=over 4 + +=item B<data>: + +The I<data> URI scheme is specified in RFC 2397. It allows inclusion +of small data items as "immediate" data, as if it had been included +externally. + +C<URI> objects belonging to the data scheme support the common methods +and two new methods to access their scheme-specific components: +$uri->media_type and $uri->data. See L<URI::data> for details. + +=item B<file>: + +An old specification of the I<file> URI scheme is found in RFC 1738. +A new RFC 2396 based specification in not available yet, but file URI +references are in common use. + +C<URI> objects belonging to the file scheme support the common and +generic methods. In addition, they provide two methods for mapping file URIs +back to local file names; $uri->file and $uri->dir. See L<URI::file> +for details. + +=item B<ftp>: + +An old specification of the I<ftp> URI scheme is found in RFC 1738. A +new RFC 2396 based specification in not available yet, but ftp URI +references are in common use. + +C<URI> objects belonging to the ftp scheme support the common, +generic and server methods. In addition, they provide two methods for +accessing the userinfo sub-components: $uri->user and $uri->password. + +=item B<gopher>: + +The I<gopher> URI scheme is specified in +<draft-murali-url-gopher-1996-12-04> and will hopefully be available +as a RFC 2396 based specification. + +C<URI> objects belonging to the gopher scheme support the common, +generic and server methods. In addition, they support some methods for +accessing gopher-specific path components: $uri->gopher_type, +$uri->selector, $uri->search, $uri->string. + +=item B<http>: + +The I<http> URI scheme is specified in RFC 2616. +The scheme is used to reference resources hosted by HTTP servers. + +C<URI> objects belonging to the http scheme support the common, +generic and server methods. + +=item B<https>: + +The I<https> URI scheme is a Netscape invention which is commonly +implemented. The scheme is used to reference HTTP servers through SSL +connections. Its syntax is the same as http, but the default +port is different. + +=item B<ldap>: + +The I<ldap> URI scheme is specified in RFC 2255. LDAP is the +Lightweight Directory Access Protocol. An ldap URI describes an LDAP +search operation to perform to retrieve information from an LDAP +directory. + +C<URI> objects belonging to the ldap scheme support the common, +generic and server methods as well as ldap-specific methods: $uri->dn, +$uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See +L<URI::ldap> for details. + +=item B<ldapi>: + +Like the I<ldap> URI scheme, but uses a UNIX domain socket. The +server methods are not supported, and the local socket path is +available as $uri->un_path. The I<ldapi> scheme is used by the +OpenLDAP package. There is no real specification for it, but it is +mentioned in various OpenLDAP manual pages. + +=item B<ldaps>: + +Like the I<ldap> URI scheme, but uses an SSL connection. This +scheme is deprecated, as the preferred way is to use the I<start_tls> +mechanism. + +=item B<mailto>: + +The I<mailto> URI scheme is specified in RFC 2368. The scheme was +originally used to designate the Internet mailing address of an +individual or service. It has (in RFC 2368) been extended to allow +setting of other mail header fields and the message body. + +C<URI> objects belonging to the mailto scheme support the common +methods and the generic query methods. In addition, they support the +following mailto-specific methods: $uri->to, $uri->headers. + +Note that the "foo@example.com" part of a mailto is I<not> the +C<userinfo> and C<host> but instead the C<path>. This allows a +mailto URI to contain multiple comma separated email addresses. + +=item B<mms>: + +The I<mms> URL specification can be found at L<http://sdp.ppona.com/>. +C<URI> objects belonging to the mms scheme support the common, +generic, and server methods, with the exception of userinfo and +query-related sub-components. + +=item B<news>: + +The I<news>, I<nntp> and I<snews> URI schemes are specified in +<draft-gilman-news-url-01> and will hopefully be available as an RFC +2396 based specification soon. + +C<URI> objects belonging to the news scheme support the common, +generic and server methods. In addition, they provide some methods to +access the path: $uri->group and $uri->message. + +=item B<nntp>: + +See I<news> scheme. + +=item B<pop>: + +The I<pop> URI scheme is specified in RFC 2384. The scheme is used to +reference a POP3 mailbox. + +C<URI> objects belonging to the pop scheme support the common, generic +and server methods. In addition, they provide two methods to access the +userinfo components: $uri->user and $uri->auth + +=item B<rlogin>: + +An old specification of the I<rlogin> URI scheme is found in RFC +1738. C<URI> objects belonging to the rlogin scheme support the +common, generic and server methods. + +=item B<rtsp>: + +The I<rtsp> URL specification can be found in section 3.2 of RFC 2326. +C<URI> objects belonging to the rtsp scheme support the common, +generic, and server methods, with the exception of userinfo and +query-related sub-components. + +=item B<rtspu>: + +The I<rtspu> URI scheme is used to talk to RTSP servers over UDP +instead of TCP. The syntax is the same as rtsp. + +=item B<rsync>: + +Information about rsync is available from L<http://rsync.samba.org/>. +C<URI> objects belonging to the rsync scheme support the common, +generic and server methods. In addition, they provide methods to +access the userinfo sub-components: $uri->user and $uri->password. + +=item B<sip>: + +The I<sip> URI specification is described in sections 19.1 and 25 +of RFC 3261. C<URI> objects belonging to the sip scheme support the +common, generic, and server methods with the exception of path related +sub-components. In addition, they provide two methods to get and set +I<sip> parameters: $uri->params_form and $uri->params. + +=item B<sips>: + +See I<sip> scheme. Its syntax is the same as sip, but the default +port is different. + +=item B<snews>: + +See I<news> scheme. Its syntax is the same as news, but the default +port is different. + +=item B<telnet>: + +An old specification of the I<telnet> URI scheme is found in RFC +1738. C<URI> objects belonging to the telnet scheme support the +common, generic and server methods. + +=item B<tn3270>: + +These URIs are used like I<telnet> URIs but for connections to IBM +mainframes. C<URI> objects belonging to the tn3270 scheme support the +common, generic and server methods. + +=item B<ssh>: + +Information about ssh is available at L<http://www.openssh.com/>. +C<URI> objects belonging to the ssh scheme support the common, +generic and server methods. In addition, they provide methods to +access the userinfo sub-components: $uri->user and $uri->password. + +=item B<urn>: + +The syntax of Uniform Resource Names is specified in RFC 2141. C<URI> +objects belonging to the urn scheme provide the common methods, and also the +methods $uri->nid and $uri->nss, which return the Namespace Identifier +and the Namespace-Specific String respectively. + +The Namespace Identifier basically works like the Scheme identifier of +URIs, and further divides the URN namespace. Namespace Identifier +assignments are maintained at +L<http://www.iana.org/assignments/urn-namespaces>. + +Letter case is not significant for the Namespace Identifier. It is +always returned in lower case by the $uri->nid method. The $uri->_nid +method can be used if you want it in its original case. + +=item B<urn>:B<isbn>: + +The C<urn:isbn:> namespace contains International Standard Book +Numbers (ISBNs) and is described in RFC 3187. A C<URI> object belonging +to this namespace has the following extra methods (if the +Business::ISBN module is available): $uri->isbn, +$uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code, +which is still supported by issues a deprecation warning), $uri->isbn_as_ean. + +=item B<urn>:B<oid>: + +The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is +described in RFC 3061. An object identifier consists of sequences of digits +separated by dots. A C<URI> object belonging to this namespace has an +additional method called $uri->oid that can be used to get/set the oid +value. In a list context, oid numbers are returned as separate elements. + +=back + +=head1 CONFIGURATION VARIABLES + +The following configuration variables influence how the class and its +methods behave: + +=over 4 + +=item $URI::ABS_ALLOW_RELATIVE_SCHEME + +Some older parsers used to allow the scheme name to be present in the +relative URL if it was the same as the base URL scheme. RFC 2396 says +that this should be avoided, but you can enable this old behaviour by +setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value. +The difference is demonstrated by the following examples: + + URI->new("http:foo")->abs("http://host/a/b") + ==> "http:foo" + + local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; + URI->new("http:foo")->abs("http://host/a/b") + ==> "http:/host/a/foo" + + +=item $URI::ABS_REMOTE_LEADING_DOTS + +You can also have the abs() method ignore excess ".." +segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS +to a TRUE value. The difference is demonstrated by the following +examples: + + URI->new("../../../foo")->abs("http://host/a/b") + ==> "http://host/../../foo" + + local $URI::ABS_REMOTE_LEADING_DOTS = 1; + URI->new("../../../foo")->abs("http://host/a/b") + ==> "http://host/foo" + +=item $URI::DEFAULT_QUERY_FORM_DELIMITER + +This value can be set to ";" to have the query form C<key=value> pairs +delimited by ";" instead of "&" which is the default. + +=back + +=head1 BUGS + +Using regexp variables like $1 directly as arguments to the URI methods +does not work too well with current perl implementations. I would argue +that this is actually a bug in perl. The workaround is to quote +them. Example: + + /(...)/ || die; + $u->query("$1"); + +=head1 PARSING URIs WITH REGEXP + +As an alternative to this module, the following (official) regular +expression can be used to decode a URI: + + my($scheme, $authority, $path, $query, $fragment) = + $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; + +The C<URI::Split> module provides the function uri_split() as a +readable alternative. + +=head1 SEE ALSO + +L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>, +L<URI::Split>, L<URI::Heuristic> + +RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax", +Berners-Lee, Fielding, Masinter, August 1998. + +L<http://www.iana.org/assignments/uri-schemes> + +L<http://www.iana.org/assignments/urn-namespaces> + +L<http://www.w3.org/Addressing/> + +=head1 COPYRIGHT + +Copyright 1995-2009 Gisle Aas. + +Copyright 1995 Martijn Koster. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHORS / ACKNOWLEDGMENTS + +This module is based on the C<URI::URL> module, which in turn was +(distantly) based on the C<wwwurl.pl> code in the libwww-perl for +perl4 developed by Roy Fielding, as part of the Arcadia project at the +University of California, Irvine, with contributions from Brooks +Cutter. + +C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and +Martijn Koster with input from other people on the libwww-perl mailing +list. + +C<URI> and related subclasses was developed by Gisle Aas. + +=cut diff --git a/Master/tlpkg/tlperl/lib/URI/Escape.pm b/Master/tlpkg/tlperl/lib/URI/Escape.pm new file mode 100644 index 00000000000..32855e37576 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/Escape.pm @@ -0,0 +1,208 @@ +package URI::Escape; +use strict; + +=head1 NAME + +URI::Escape - Percent-encode and percent-decode unsafe characters + +=head1 SYNOPSIS + + use URI::Escape; + $safe = uri_escape("10% is enough\n"); + $verysafe = uri_escape("foo", "\0-\377"); + $str = uri_unescape($safe); + +=head1 DESCRIPTION + +This module provides functions to percent-encode and percent-decode URI strings as +defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping". +This is the terminology used by this module, which predates the formalization of the +terms by the RFC by several years. + +A URI consists of a restricted set of characters. The restricted set +of characters consists of digits, letters, and a few graphic symbols +chosen from those common to most of the character encodings and input +facilities available to Internet users. They are made up of the +"unreserved" and "reserved" character sets as defined in RFC 3986. + + unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" + reserved = ":" / "/" / "?" / "#" / "[" / "]" / "@" + "!" / "$" / "&" / "'" / "(" / ")" + / "*" / "+" / "," / ";" / "=" + +In addition, any byte (octet) can be represented in a URI by an escape +sequence: a triplet consisting of the character "%" followed by two +hexadecimal digits. A byte can also be represented directly by a +character, using the US-ASCII character for that octet. + +Some of the characters are I<reserved> for use as delimiters or as +part of certain URI components. These must be escaped if they are to +be treated as ordinary data. Read RFC 3986 for further details. + +The functions provided (and exported by default) from this module are: + +=over 4 + +=item uri_escape( $string ) + +=item uri_escape( $string, $unsafe ) + +Replaces each unsafe character in the $string with the corresponding +escape sequence and returns the result. The $string argument should +be a string of bytes. The uri_escape() function will croak if given a +characters with code above 255. Use uri_escape_utf8() if you know you +have such chars or/and want chars in the 128 .. 255 range treated as +UTF-8. + +The uri_escape() function takes an optional second argument that +overrides the set of characters that are to be escaped. The set is +specified as a string that can be used in a regular expression +character class (between [ ]). E.g.: + + "\x00-\x1f\x7f-\xff" # all control and hi-bit characters + "a-z" # all lower case characters + "^A-Za-z" # everything not a letter + +The default set of characters to be escaped is all those which are +I<not> part of the C<unreserved> character class shown above as well +as the reserved characters. I.e. the default is: + + "^A-Za-z0-9\-\._~" + +=item uri_escape_utf8( $string ) + +=item uri_escape_utf8( $string, $unsafe ) + +Works like uri_escape(), but will encode chars as UTF-8 before +escaping them. This makes this function able to deal with characters +with code above 255 in $string. Note that chars in the 128 .. 255 +range will be escaped differently by this function compared to what +uri_escape() would. For chars in the 0 .. 127 range there is no +difference. + +Equivalent to: + + utf8::encode($string); + my $uri = uri_escape($string); + +Note: JavaScript has a function called escape() that produces the +sequence "%uXXXX" for chars in the 256 .. 65535 range. This function +has really nothing to do with URI escaping but some folks got confused +since it "does the right thing" in the 0 .. 255 range. Because of +this you sometimes see "URIs" with these kind of escapes. The +JavaScript encodeURIComponent() function is similar to uri_escape_utf8(). + +=item uri_unescape($string,...) + +Returns a string with each %XX sequence replaced with the actual byte +(octet). + +This does the same as: + + $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + +but does not modify the string in-place as this RE would. Using the +uri_unescape() function instead of the RE might make the code look +cleaner and is a few characters less to type. + +In a simple benchmark test I did, +calling the function (instead of the inline RE above) if a few chars +were unescaped was something like 40% slower, and something like 700% slower if none were. If +you are going to unescape a lot of times it might be a good idea to +inline the RE. + +If the uri_unescape() function is passed multiple strings, then each +one is returned unescaped. + +=back + +The module can also export the C<%escapes> hash, which contains the +mapping from all 256 bytes to the corresponding escape codes. Lookup +in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))> +each time. + +=head1 SEE ALSO + +L<URI> + + +=head1 COPYRIGHT + +Copyright 1995-2004 Gisle Aas. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +require Exporter; +our @ISA = qw(Exporter); +our %escapes; +our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8); +our @EXPORT_OK = qw(%escapes); +our $VERSION = "3.30"; + +use Carp (); + +# Build a char->hex map +for (0..255) { + $escapes{chr($_)} = sprintf("%%%02X", $_); +} + +my %subst; # compiled patterns + +my %Unsafe = ( + RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/, + RFC3986 => qr/[^A-Za-z0-9\-\._~]/, +); + +sub uri_escape { + my($text, $patn) = @_; + return undef unless defined $text; + if (defined $patn){ + unless (exists $subst{$patn}) { + # Because we can't compile the regex we fake it with a cached sub + (my $tmp = $patn) =~ s,/,\\/,g; + eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }"; + Carp::croak("uri_escape: $@") if $@; + } + &{$subst{$patn}}($text); + } else { + $text =~ s/($Unsafe{RFC3986})/$escapes{$1} || _fail_hi($1)/ge; + } + $text; +} + +sub _fail_hi { + my $chr = shift; + Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr)); +} + +sub uri_escape_utf8 { + my $text = shift; + utf8::encode($text); + return uri_escape($text, @_); +} + +sub uri_unescape { + # Note from RFC1630: "Sequences which start with a percent sign + # but are not followed by two hexadecimal characters are reserved + # for future extension" + my $str = shift; + if (@_ && wantarray) { + # not executed for the common case of a single argument + my @str = ($str, @_); # need to copy + for (@str) { + s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + } + return @str; + } + $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str; + $str; +} + +sub escape_char { + return join '', @URI::Escape::escapes{$_[0] =~ /(\C)/g}; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/Heuristic.pm b/Master/tlpkg/tlperl/lib/URI/Heuristic.pm new file mode 100644 index 00000000000..f02fe376a44 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/Heuristic.pm @@ -0,0 +1,253 @@ +package URI::Heuristic; + +=head1 NAME + +URI::Heuristic - Expand URI using heuristics + +=head1 SYNOPSIS + + use URI::Heuristic qw(uf_uristr); + $u = uf_uristr("perl"); # http://www.perl.com + $u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol + $u = uf_uristr("aas"); # http://www.aas.no + $u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi + $u = uf_uristr("/etc/passwd"); # file:/etc/passwd + +=head1 DESCRIPTION + +This module provides functions that expand strings into real absolute +URIs using some built-in heuristics. Strings that already represent +absolute URIs (i.e. that start with a C<scheme:> part) are never modified +and are returned unchanged. The main use of these functions is to +allow abbreviated URIs similar to what many web browsers allow for URIs +typed in by the user. + +The following functions are provided: + +=over 4 + +=item uf_uristr($str) + +Tries to make the argument string +into a proper absolute URI string. The "uf_" prefix stands for "User +Friendly". Under MacOS, it assumes that any string with a common URL +scheme (http, ftp, etc.) is a URL rather than a local path. So don't name +your volumes after common URL schemes and expect uf_uristr() to construct +valid file: URL's on those volumes for you, because it won't. + +=item uf_uri($str) + +Works the same way as uf_uristr() but +returns a C<URI> object. + +=back + +=head1 ENVIRONMENT + +If the hostname portion of a URI does not contain any dots, then +certain qualified guesses are made. These guesses are governed by +the following environment variables: + +=over 10 + +=item COUNTRY + +The two-letter country code (ISO 3166) for your location. If +the domain name of your host ends with two letters, then it is taken +to be the default country. See also L<Locale::Country>. + +=item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG + +If COUNTRY is not set, these standard environment variables are +examined and country (not language) information possibly found in them +is used as the default country. + +=item URL_GUESS_PATTERN + +Contains a space-separated list of URL patterns to try. The string +"ACME" is for some reason used as a placeholder for the host name in +the URL provided. Example: + + URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com" + export URL_GUESS_PATTERN + +Specifying URL_GUESS_PATTERN disables any guessing rules based on +country. An empty URL_GUESS_PATTERN disables any guessing that +involves host name lookups. + +=back + +=head1 COPYRIGHT + +Copyright 1997-1998, Gisle Aas + +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(@EXPORT_OK $VERSION $MY_COUNTRY %LOCAL_GUESSING $DEBUG); + +require Exporter; +*import = \&Exporter::import; +@EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr); +$VERSION = "4.19"; + +sub MY_COUNTRY() { + for ($MY_COUNTRY) { + return $_ if defined; + + # First try the environment. + $_ = $ENV{COUNTRY}; + return $_ if defined; + + # Try the country part of LC_ALL and LANG from environment + my @srcs = ($ENV{LC_ALL}, $ENV{LANG}); + # ...and HTTP_ACCEPT_LANGUAGE before those if present + if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) { + # TODO: q-value processing/ordering + for $httplang (split(/\s*,\s*/, $httplang)) { + if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) { + unshift(@srcs, "${1}_${2}"); + last; + } + } + } + for (@srcs) { + next unless defined; + return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/; + } + + # Last bit of domain name. This may access the network. + require Net::Domain; + my $fqdn = Net::Domain::hostfqdn(); + $_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/; + return $_ if defined; + + # Give up. Defined but false. + return ($_ = 0); + } +} + +%LOCAL_GUESSING = +( + 'us' => [qw(www.ACME.gov www.ACME.mil)], + 'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)], + 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)], + 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)], + # send corrections and new entries to <gisle@aas.no> +); +# Backwards compatibility; uk != United Kingdom in ISO 3166 +$LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb}; + + +sub uf_uristr ($) +{ + local($_) = @_; + print STDERR "uf_uristr: resolving $_\n" if $DEBUG; + return unless defined; + + s/^\s+//; + s/\s+$//; + + if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) { + $_ = "http://$_"; + + } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) { + $_ = lc($1) . "://$_"; + + } elsif ($^O ne "MacOS" && + (m,^/, || # absolute file name + m,^\.\.?/, || # relative file name + m,^[a-zA-Z]:[/\\],) # dosish file name + ) + { + $_ = "file:$_"; + + } elsif ($^O eq "MacOS" && m/:/) { + # potential MacOS file name + unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) { + require URI::file; + my $a = URI::file->new($_)->as_string; + $_ = ($a =~ m/^file:/) ? $a : "file:$a"; + } + } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) { + $_ = "mailto:$_"; + + } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified + if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) { + my $host = $1; + + my $scheme = "http"; + if (/^:(\d+)\b/) { + # Some more or less well known ports + if ($1 =~ /^[56789]?443$/) { + $scheme = "https"; + } elsif ($1 eq "21") { + $scheme = "ftp"; + } + } + + if ($host !~ /\./ && $host ne "localhost") { + my @guess; + if (exists $ENV{URL_GUESS_PATTERN}) { + @guess = map { s/\bACME\b/$host/; $_ } + split(' ', $ENV{URL_GUESS_PATTERN}); + } else { + if (MY_COUNTRY()) { + my $special = $LOCAL_GUESSING{MY_COUNTRY()}; + if ($special) { + my @special = @$special; + push(@guess, map { s/\bACME\b/$host/; $_ } + @special); + } else { + push(@guess, "www.$host." . MY_COUNTRY()); + } + } + push(@guess, map "www.$host.$_", + "com", "org", "net", "edu", "int"); + } + + + my $guess; + for $guess (@guess) { + print STDERR "uf_uristr: gethostbyname('$guess.')..." + if $DEBUG; + if (gethostbyname("$guess.")) { + print STDERR "yes\n" if $DEBUG; + $host = $guess; + last; + } + print STDERR "no\n" if $DEBUG; + } + } + $_ = "$scheme://$host$_"; + + } else { + # pure junk, just return it unchanged... + + } + } + print STDERR "uf_uristr: ==> $_\n" if $DEBUG; + + $_; +} + +sub uf_uri ($) +{ + require URI; + URI->new(uf_uristr($_[0])); +} + +# legacy +*uf_urlstr = \*uf_uristr; + +sub uf_url ($) +{ + require URI::URL; + URI::URL->new(uf_uristr($_[0])); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/IRI.pm b/Master/tlpkg/tlperl/lib/URI/IRI.pm new file mode 100644 index 00000000000..39336fce5ac --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/IRI.pm @@ -0,0 +1,44 @@ +package URI::IRI; + +# Experimental + +use strict; +use URI (); + +use overload '""' => sub { shift->as_string }; + +sub new { + my($class, $uri, $scheme) = @_; + utf8::upgrade($uri); + return bless { + uri => URI->new($uri, $scheme), + }, $class; +} + +sub clone { + my $self = shift; + return bless { + uri => $self->{uri}->clone, + }, ref($self); +} + +sub as_string { + my $self = shift; + return $self->{uri}->as_iri; +} + +sub AUTOLOAD +{ + use vars qw($AUTOLOAD); + my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); + + # We create the function here so that it will not need to be + # autoloaded the next time. + no strict 'refs'; + *$method = sub { shift->{uri}->$method(@_) }; + goto &$method; +} + +sub DESTROY {} # avoid AUTOLOADing it + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/QueryParam.pm b/Master/tlpkg/tlperl/lib/URI/QueryParam.pm new file mode 100644 index 00000000000..3f634b12b77 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/QueryParam.pm @@ -0,0 +1,200 @@ +package URI::QueryParam; + +use strict; + +sub URI::_query::query_param { + my $self = shift; + my @old = $self->query_form; + + if (@_ == 0) { + # get keys + my %seen; + my @keys; + for (my $i = 0; $i < @old; $i += 2) { + push(@keys, $old[$i]) unless $seen{$old[$i]}++; + } + return @keys; + } + + my $key = shift; + my @i; + + for (my $i = 0; $i < @old; $i += 2) { + push(@i, $i) if $old[$i] eq $key; + } + + if (@_) { + my @new = @old; + my @new_i = @i; + my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; + #print "VALS:@vals [@i]\n"; + while (@new_i > @vals) { + #print "REMOVE $new_i[-1]\n"; + splice(@new, pop(@new_i), 2); + } + while (@vals > @new_i) { + my $i = @new_i ? $new_i[-1] + 2 : @new; + #print "SPLICE $i\n"; + splice(@new, $i, 0, $key => pop(@vals)); + } + for (@vals) { + #print "SET $new_i[0]\n"; + $new[shift(@new_i)+1] = $_; + } + + $self->query_form(\@new); + } + + return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef; +} + +sub URI::_query::query_param_append { + my $self = shift; + my $key = shift; + $self->query_form($self->query_form, $key => \@_); # XXX + return; +} + +sub URI::_query::query_param_delete { + my $self = shift; + my $key = shift; + my @old = $self->query_form; + my @vals; + + for (my $i = @old - 2; $i >= 0; $i -= 2) { + next if $old[$i] ne $key; + push(@vals, (splice(@old, $i, 2))[1]); + } + $self->query_form(\@old) if @vals; + return wantarray ? reverse @vals : $vals[-1]; +} + +sub URI::_query::query_form_hash { + my $self = shift; + my @old = $self->query_form; + if (@_) { + $self->query_form(@_ == 1 ? %{shift(@_)} : @_); + } + my %hash; + while (my($k, $v) = splice(@old, 0, 2)) { + if (exists $hash{$k}) { + for ($hash{$k}) { + $_ = [$_] unless ref($_) eq "ARRAY"; + push(@$_, $v); + } + } + else { + $hash{$k} = $v; + } + } + return \%hash; +} + +1; + +__END__ + +=head1 NAME + +URI::QueryParam - Additional query methods for URIs + +=head1 SYNOPSIS + + use URI; + use URI::QueryParam; + + $u = URI->new("", "http"); + $u->query_param(foo => 1, 2, 3); + print $u->query; # prints foo=1&foo=2&foo=3 + + for my $key ($u->query_param) { + print "$key: ", join(", ", $u->query_param($key)), "\n"; + } + +=head1 DESCRIPTION + +Loading the C<URI::QueryParam> module adds some extra methods to +URIs that support query methods. These methods provide an alternative +interface to the $u->query_form data. + +The query_param_* methods have deliberately been made identical to the +interface of the corresponding C<CGI.pm> methods. + +The following additional methods are made available: + +=over + +=item @keys = $u->query_param + +=item @values = $u->query_param( $key ) + +=item $first_value = $u->query_param( $key ) + +=item $u->query_param( $key, $value,... ) + +If $u->query_param is called with no arguments, it returns all the +distinct parameter keys of the URI. In a scalar context it returns the +number of distinct keys. + +When a $key argument is given, the method returns the parameter values with the +given key. In a scalar context, only the first parameter value is +returned. + +If additional arguments are given, they are used to update successive +parameters with the given key. If any of the values provided are +array references, then the array is dereferenced to get the actual +values. + +=item $u->query_param_append($key, $value,...) + +Adds new parameters with the given +key without touching any old parameters with the same key. It +can be explained as a more efficient version of: + + $u->query_param($key, + $u->query_param($key), + $value,...); + +One difference is that this expression would return the old values +of $key, whereas the query_param_append() method does not. + +=item @values = $u->query_param_delete($key) + +=item $first_value = $u->query_param_delete($key) + +Deletes all key/value pairs with the given key. +The old values are returned. In a scalar context, only the first value +is returned. + +Using the query_param_delete() method is slightly more efficient than +the equivalent: + + $u->query_param($key, []); + +=item $hashref = $u->query_form_hash + +=item $u->query_form_hash( \%new_form ) + +Returns a reference to a hash that represents the +query form's key/value pairs. If a key occurs multiple times, then the hash +value becomes an array reference. + +Note that sequence information is lost. This means that: + + $u->query_form_hash($u->query_form_hash); + +is not necessarily a no-op, as it may reorder the key/value pairs. +The values returned by the query_param() method should stay the same +though. + +=back + +=head1 SEE ALSO + +L<URI>, L<CGI> + +=head1 COPYRIGHT + +Copyright 2002 Gisle Aas. + +=cut diff --git a/Master/tlpkg/tlperl/lib/URI/Split.pm b/Master/tlpkg/tlperl/lib/URI/Split.pm new file mode 100644 index 00000000000..ad430b93277 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/Split.pm @@ -0,0 +1,96 @@ +package URI::Split; + +use strict; + +use vars qw(@ISA @EXPORT_OK); +require Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(uri_split uri_join); + +use URI::Escape (); + +sub uri_split { + return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; +} + +sub uri_join { + my($scheme, $auth, $path, $query, $frag) = @_; + my $uri = defined($scheme) ? "$scheme:" : ""; + $path = "" unless defined $path; + if (defined $auth) { + $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg; + $uri .= "//$auth"; + $path = "/$path" if length($path) && $path !~ m,^/,; + } + elsif ($path =~ m,^//,) { + $uri .= "//"; # XXX force empty auth + } + unless (length $uri) { + $path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,; + } + $path =~ s,([?\#]), URI::Escape::escape_char($1),eg; + $uri .= $path; + if (defined $query) { + $query =~ s,(\#), URI::Escape::escape_char($1),eg; + $uri .= "?$query"; + } + $uri .= "#$frag" if defined $frag; + $uri; +} + +1; + +__END__ + +=head1 NAME + +URI::Split - Parse and compose URI strings + +=head1 SYNOPSIS + + use URI::Split qw(uri_split uri_join); + ($scheme, $auth, $path, $query, $frag) = uri_split($uri); + $uri = uri_join($scheme, $auth, $path, $query, $frag); + +=head1 DESCRIPTION + +Provides functions to parse and compose URI +strings. The following functions are provided: + +=over + +=item ($scheme, $auth, $path, $query, $frag) = uri_split($uri) + +Breaks up a URI string into its component +parts. An C<undef> value is returned for those parts that are not +present. The $path part is always present (but can be the empty +string) and is thus never returned as C<undef>. + +No sensible value is returned if this function is called in a scalar +context. + +=item $uri = uri_join($scheme, $auth, $path, $query, $frag) + +Puts together a URI string from its parts. +Missing parts are signaled by passing C<undef> for the corresponding +argument. + +Minimal escaping is applied to parts that contain reserved chars +that would confuse a parser. For instance, any occurrence of '?' or '#' +in $path is always escaped, as it would otherwise be parsed back +as a query or fragment. + +=back + +=head1 SEE ALSO + +L<URI>, L<URI::Escape> + +=head1 COPYRIGHT + +Copyright 2003, 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/URI/URL.pm b/Master/tlpkg/tlperl/lib/URI/URL.pm new file mode 100644 index 00000000000..77354488c86 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/URL.pm @@ -0,0 +1,305 @@ +package URI::URL; + +require URI::WithBase; +@ISA=qw(URI::WithBase); + +use strict; +use vars qw(@EXPORT $VERSION); + +$VERSION = "5.03"; + +# Provide as much as possible of the old URI::URL interface for backwards +# compatibility... + +require Exporter; +*import = \&Exporter::import; +@EXPORT = qw(url); + +# Easy to use constructor +sub url ($;$) { URI::URL->new(@_); } + +use URI::Escape qw(uri_unescape); + +sub new +{ + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->[0] = $self->[0]->canonical; + $self; +} + +sub newlocal +{ + my $class = shift; + require URI::file; + bless [URI::file->new_abs(shift)], $class; +} + +{package URI::_foreign; + sub _init # hope it is not defined + { + my $class = shift; + die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT; + $class->SUPER::_init(@_); + } +} + +sub strict +{ + my $old = $URI::URL::STRICT; + $URI::URL::STRICT = shift if @_; + $old; +} + +sub print_on +{ + my $self = shift; + require Data::Dumper; + print STDERR Data::Dumper::Dumper($self); +} + +sub _try +{ + my $self = shift; + my $method = shift; + scalar(eval { $self->$method(@_) }); +} + +sub crack +{ + # should be overridden by subclasses + my $self = shift; + (scalar($self->scheme), + $self->_try("user"), + $self->_try("password"), + $self->_try("host"), + $self->_try("port"), + $self->_try("path"), + $self->_try("params"), + $self->_try("query"), + scalar($self->fragment), + ) +} + +sub full_path +{ + my $self = shift; + my $path = $self->path_query; + $path = "/" unless length $path; + $path; +} + +sub netloc +{ + shift->authority(@_); +} + +sub epath +{ + my $path = shift->SUPER::path(@_); + $path =~ s/;.*//; + $path; +} + +sub eparams +{ + my $self = shift; + my @p = $self->path_segments; + return unless ref($p[-1]); + @p = @{$p[-1]}; + shift @p; + join(";", @p); +} + +sub params { shift->eparams(@_); } + +sub path { + my $self = shift; + my $old = $self->epath(@_); + return unless defined wantarray; + return '/' if !defined($old) || !length($old); + Carp::croak("Path components contain '/' (you must call epath)") + if $old =~ /%2[fF]/ and !@_; + $old = "/$old" if $old !~ m|^/| && defined $self->netloc; + return uri_unescape($old); +} + +sub path_components { + shift->path_segments(@_); +} + +sub query { + my $self = shift; + my $old = $self->equery(@_); + if (defined(wantarray) && defined($old)) { + if ($old =~ /%(?:26|2[bB]|3[dD])/) { # contains escaped '=' '&' or '+' + my $mess; + for ($old) { + $mess = "Query contains both '+' and '%2B'" + if /\+/ && /%2[bB]/; + $mess = "Form query contains escaped '=' or '&'" + if /=/ && /%(?:3[dD]|26)/; + } + if ($mess) { + Carp::croak("$mess (you must call equery)"); + } + } + # Now it should be safe to unescape the string without loosing + # information + return uri_unescape($old); + } + undef; + +} + +sub abs +{ + my $self = shift; + my $base = shift; + my $allow_scheme = shift; + $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME + unless defined $allow_scheme; + local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme; + local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS; + $self->SUPER::abs($base); +} + +sub frag { shift->fragment(@_); } +sub keywords { shift->query_keywords(@_); } + +# file: +sub local_path { shift->file; } +sub unix_path { shift->file("unix"); } +sub dos_path { shift->file("dos"); } +sub mac_path { shift->file("mac"); } +sub vms_path { shift->file("vms"); } + +# mailto: +sub address { shift->to(@_); } +sub encoded822addr { shift->to(@_); } +sub URI::mailto::authority { shift->to(@_); } # make 'netloc' method work + +# news: +sub groupart { shift->_group(@_); } +sub article { shift->message(@_); } + +1; + +__END__ + +=head1 NAME + +URI::URL - Uniform Resource Locators + +=head1 SYNOPSIS + + $u1 = URI::URL->new($str, $base); + $u2 = $u1->abs; + +=head1 DESCRIPTION + +This module is provided for backwards compatibility with modules that +depend on the interface provided by the C<URI::URL> class that used to +be distributed with the libwww-perl library. + +The following differences exist compared to the C<URI> class interface: + +=over 3 + +=item * + +The URI::URL module exports the url() function as an alternate +constructor interface. + +=item * + +The constructor takes an optional $base argument. The C<URI::URL> +class is a subclass of C<URI::WithBase>. + +=item * + +The URI::URL->newlocal class method is the same as URI::file->new_abs. + +=item * + +URI::URL::strict(1) + +=item * + +$url->print_on method + +=item * + +$url->crack method + +=item * + +$url->full_path: same as ($uri->abs_path || "/") + +=item * + +$url->netloc: same as $uri->authority + +=item * + +$url->epath, $url->equery: same as $uri->path, $uri->query + +=item * + +$url->path and $url->query pass unescaped strings. + +=item * + +$url->path_components: same as $uri->path_segments (if you don't +consider path segment parameters) + +=item * + +$url->params and $url->eparams methods + +=item * + +$url->base method. See L<URI::WithBase>. + +=item * + +$url->abs and $url->rel have an optional $base argument. See +L<URI::WithBase>. + +=item * + +$url->frag: same as $uri->fragment + +=item * + +$url->keywords: same as $uri->query_keywords + +=item * + +$url->localpath and friends map to $uri->file. + +=item * + +$url->address and $url->encoded822addr: same as $uri->to for mailto URI + +=item * + +$url->groupart method for news URI + +=item * + +$url->article: same as $uri->message + +=back + + + +=head1 SEE ALSO + +L<URI>, L<URI::WithBase> + +=head1 COPYRIGHT + +Copyright 1998-2000 Gisle Aas. + +=cut diff --git a/Master/tlpkg/tlperl/lib/URI/WithBase.pm b/Master/tlpkg/tlperl/lib/URI/WithBase.pm new file mode 100644 index 00000000000..0337c6b6450 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/WithBase.pm @@ -0,0 +1,171 @@ +package URI::WithBase; + +use strict; +use vars qw($AUTOLOAD $VERSION); +use URI; + +$VERSION = "2.19"; + +use overload '""' => "as_string", fallback => 1; + +sub as_string; # help overload find it + +sub new +{ + my($class, $uri, $base) = @_; + my $ibase = $base; + if ($base && ref($base) && UNIVERSAL::isa($base, __PACKAGE__)) { + $base = $base->abs; + $ibase = $base->[0]; + } + bless [URI->new($uri, $ibase), $base], $class; +} + +sub new_abs +{ + my $class = shift; + my $self = $class->new(@_); + $self->abs; +} + +sub _init +{ + my $class = shift; + my($str, $scheme) = @_; + bless [URI->new($str, $scheme), undef], $class; +} + +sub eq +{ + my($self, $other) = @_; + $other = $other->[0] if UNIVERSAL::isa($other, __PACKAGE__); + $self->[0]->eq($other); +} + +sub AUTOLOAD +{ + my $self = shift; + my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); + return if $method eq "DESTROY"; + $self->[0]->$method(@_); +} + +sub can { # override UNIVERSAL::can + my $self = shift; + $self->SUPER::can(@_) || ( + ref($self) + ? $self->[0]->can(@_) + : undef + ) +} + +sub base { + my $self = shift; + my $base = $self->[1]; + + if (@_) { # set + my $new_base = shift; + # ensure absoluteness + $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__); + $self->[1] = $new_base; + } + return unless defined wantarray; + + # The base attribute supports 'lazy' conversion from URL strings + # to URL objects. Strings may be stored but when a string is + # fetched it will automatically be converted to a URL object. + # The main benefit is to make it much cheaper to say: + # URI::WithBase->new($random_url_string, 'http:') + if (defined($base) && !ref($base)) { + $base = ref($self)->new($base); + $self->[1] = $base unless @_; + } + $base; +} + +sub clone +{ + my $self = shift; + my $base = $self->[1]; + $base = $base->clone if ref($base); + bless [$self->[0]->clone, $base], ref($self); +} + +sub abs +{ + my $self = shift; + my $base = shift || $self->base || return $self->clone; + $base = $base->as_string if ref($base); + bless [$self->[0]->abs($base, @_), $base], ref($self); +} + +sub rel +{ + my $self = shift; + my $base = shift || $self->base || return $self->clone; + $base = $base->as_string if ref($base); + bless [$self->[0]->rel($base, @_), $base], ref($self); +} + +1; + +__END__ + +=head1 NAME + +URI::WithBase - URIs which remember their base + +=head1 SYNOPSIS + + $u1 = URI::WithBase->new($str, $base); + $u2 = $u1->abs; + + $base = $u1->base; + $u1->base( $new_base ) + +=head1 DESCRIPTION + +This module provides the C<URI::WithBase> class. Objects of this class +are like C<URI> objects, but can keep their base too. The base +represents the context where this URI was found and can be used to +absolutize or relativize the URI. All the methods described in L<URI> +are supported for C<URI::WithBase> objects. + +The methods provided in addition to or modified from those of C<URI> are: + +=over 4 + +=item $uri = URI::WithBase->new($str, [$base]) + +The constructor takes an optional base URI as the second argument. +If provided, this argument initializes the base attribute. + +=item $uri->base( [$new_base] ) + +Can be used to get or set the value of the base attribute. +The return value, which is the old value, is a URI object or C<undef>. + +=item $uri->abs( [$base_uri] ) + +The $base_uri argument is now made optional as the object carries its +base with it. A new object is returned even if $uri is already +absolute (while plain URI objects simply return themselves in +that case). + +=item $uri->rel( [$base_uri] ) + +The $base_uri argument is now made optional as the object carries its +base with it. A new object is always returned. + +=back + + +=head1 SEE ALSO + +L<URI> + +=head1 COPYRIGHT + +Copyright 1998-2002 Gisle Aas. + +=cut diff --git a/Master/tlpkg/tlperl/lib/URI/_foreign.pm b/Master/tlpkg/tlperl/lib/URI/_foreign.pm new file mode 100644 index 00000000000..075f0fd3417 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_foreign.pm @@ -0,0 +1,6 @@ +package URI::_foreign; + +require URI::_generic; +@ISA=qw(URI::_generic); + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_generic.pm b/Master/tlpkg/tlperl/lib/URI/_generic.pm new file mode 100644 index 00000000000..9bf2e5d0781 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_generic.pm @@ -0,0 +1,249 @@ +package URI::_generic; +require URI; +require URI::_query; +@ISA=qw(URI URI::_query); + +use strict; +use URI::Escape qw(uri_unescape); +use Carp (); + +my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g; +my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; + +sub _no_scheme_ok { 1 } + +sub authority +{ + my $self = shift; + $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; + + if (@_) { + my $auth = shift; + $$self = $1; + my $rest = $3; + if (defined $auth) { + $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego; + $$self .= "//$auth"; + } + _check_path($rest, $$self); + $$self .= $rest; + } + $2; +} + +sub path +{ + my $self = shift; + $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die; + + if (@_) { + $$self = $1; + my $rest = $3; + my $new_path = shift; + $new_path = "" unless defined $new_path; + $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego; + _check_path($new_path, $$self); + $$self .= $new_path . $rest; + } + $2; +} + +sub path_query +{ + my $self = shift; + $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; + + if (@_) { + $$self = $1; + my $rest = $3; + my $new_path = shift; + $new_path = "" unless defined $new_path; + $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; + _check_path($new_path, $$self); + $$self .= $new_path . $rest; + } + $2; +} + +sub _check_path +{ + my($path, $pre) = @_; + my $prefix; + if ($pre =~ m,/,) { # authority present + $prefix = "/" if length($path) && $path !~ m,^[/?\#],; + } + else { + if ($path =~ m,^//,) { + Carp::carp("Path starting with double slash is confusing") + if $^W; + } + elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) { + Carp::carp("Path might look like scheme, './' prepended") + if $^W; + $prefix = "./"; + } + } + substr($_[0], 0, 0) = $prefix if defined $prefix; +} + +sub path_segments +{ + my $self = shift; + my $path = $self->path; + if (@_) { + my @arg = @_; # make a copy + for (@arg) { + if (ref($_)) { + my @seg = @$_; + $seg[0] =~ s/%/%25/g; + for (@seg) { s/;/%3B/g; } + $_ = join(";", @seg); + } + else { + s/%/%25/g; s/;/%3B/g; + } + s,/,%2F,g; + } + $self->path(join("/", @arg)); + } + return $path unless wantarray; + map {/;/ ? $self->_split_segment($_) + : uri_unescape($_) } + split('/', $path, -1); +} + + +sub _split_segment +{ + my $self = shift; + require URI::_segment; + URI::_segment->new(@_); +} + + +sub abs +{ + my $self = shift; + my $base = shift || Carp::croak("Missing base argument"); + + if (my $scheme = $self->scheme) { + return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME; + $base = URI->new($base) unless ref $base; + return $self unless $scheme eq $base->scheme; + } + + $base = URI->new($base) unless ref $base; + my $abs = $self->clone; + $abs->scheme($base->scheme); + return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o; + $abs->authority($base->authority); + + my $path = $self->path; + return $abs if $path =~ m,^/,; + + if (!length($path)) { + my $abs = $base->clone; + my $query = $self->query; + $abs->query($query) if defined $query; + $abs->fragment($self->fragment); + return $abs; + } + + my $p = $base->path; + $p =~ s,[^/]+$,,; + $p .= $path; + my @p = split('/', $p, -1); + shift(@p) if @p && !length($p[0]); + my $i = 1; + while ($i < @p) { + #print "$i ", join("/", @p), " ($p[$i])\n"; + if ($p[$i-1] eq ".") { + splice(@p, $i-1, 1); + $i-- if $i > 1; + } + elsif ($p[$i] eq ".." && $p[$i-1] ne "..") { + splice(@p, $i-1, 2); + if ($i > 1) { + $i--; + push(@p, "") if $i == @p; + } + } + else { + $i++; + } + } + $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/." + if ($URI::ABS_REMOTE_LEADING_DOTS) { + shift @p while @p && $p[0] =~ /^\.\.?$/; + } + $abs->path("/" . join("/", @p)); + $abs; +} + +# The opposite of $url->abs. Return a URI which is as relative as possible +sub rel { + my $self = shift; + my $base = shift || Carp::croak("Missing base argument"); + my $rel = $self->clone; + $base = URI->new($base) unless ref $base; + + #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)}; + my $scheme = $rel->scheme; + my $auth = $rel->canonical->authority; + my $path = $rel->path; + + if (!defined($scheme) && !defined($auth)) { + # it is already relative + return $rel; + } + + #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)}; + my $bscheme = $base->scheme; + my $bauth = $base->canonical->authority; + my $bpath = $base->path; + + for ($bscheme, $bauth, $auth) { + $_ = '' unless defined + } + + unless ($scheme eq $bscheme && $auth eq $bauth) { + # different location, can't make it relative + return $rel; + } + + for ($path, $bpath) { $_ = "/$_" unless m,^/,; } + + # Make it relative by eliminating scheme and authority + $rel->scheme(undef); + $rel->authority(undef); + + # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>. + # First we calculate common initial path components length ($li). + my $li = 1; + while (1) { + my $i = index($path, '/', $li); + last if $i < 0 || + $i != index($bpath, '/', $li) || + substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li); + $li=$i+1; + } + # then we nuke it from both paths + substr($path, 0,$li) = ''; + substr($bpath,0,$li) = ''; + + if ($path eq $bpath && + defined($rel->fragment) && + !defined($rel->query)) { + $rel->path(""); + } + else { + # Add one "../" for each path component left in the base path + $path = ('../' x $bpath =~ tr|/|/|) . $path; + $path = "./" if $path eq ""; + $rel->path($path); + } + + $rel; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_idna.pm b/Master/tlpkg/tlperl/lib/URI/_idna.pm new file mode 100644 index 00000000000..39366e5b831 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_idna.pm @@ -0,0 +1,78 @@ +package URI::_idna; + +# This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep) +# based on Python-2.6.4/Lib/encodings/idna.py + +use strict; +use URI::_punycode qw(encode_punycode decode_punycode); +use Carp qw(croak); + +my $ASCII = qr/^[\x00-\x7F]*\z/; + +sub encode { + my $idomain = shift; + my @labels = split(/\./, $idomain, -1); + my @last_empty; + push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq ""; + for (@labels) { + $_ = ToASCII($_); + } + return join(".", @labels, @last_empty); +} + +sub decode { + my $domain = shift; + return join(".", map ToUnicode($_), split(/\./, $domain, -1)) +} + +sub nameprep { # XXX real implementation missing + my $label = shift; + $label = lc($label); + return $label; +} + +sub check_size { + my $label = shift; + croak "Label empty" if $label eq ""; + croak "Label too long" if length($label) > 63; + return $label; +} + +sub ToASCII { + my $label = shift; + return check_size($label) if $label =~ $ASCII; + + # Step 2: nameprep + $label = nameprep($label); + # Step 3: UseSTD3ASCIIRules is false + # Step 4: try ASCII again + return check_size($label) if $label =~ $ASCII; + + # Step 5: Check ACE prefix + if ($label =~ /^xn--/) { + croak "Label starts with ACE prefix"; + } + + # Step 6: Encode with PUNYCODE + $label = encode_punycode($label); + + # Step 7: Prepend ACE prefix + $label = "xn--$label"; + + # Step 8: Check size + return check_size($label); +} + +sub ToUnicode { + my $label = shift; + $label = nameprep($label) unless $label =~ $ASCII; + return $label unless $label =~ /^xn--/; + my $result = decode_punycode(substr($label, 4)); + my $label2 = ToASCII($result); + if (lc($label) ne $label2) { + croak "IDNA does not round-trip: '\L$label\E' vs '$label2'"; + } + return $result; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_ldap.pm b/Master/tlpkg/tlperl/lib/URI/_ldap.pm new file mode 100644 index 00000000000..c9132e2aff7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_ldap.pm @@ -0,0 +1,140 @@ +# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package URI::_ldap; + +use strict; + +use vars qw($VERSION); +$VERSION = "1.11"; + +use URI::Escape qw(uri_unescape); + +sub _ldap_elem { + my $self = shift; + my $elem = shift; + my $query = $self->query; + my @bits = (split(/\?/,defined($query) ? $query : ""),("")x4); + my $old = $bits[$elem]; + + if (@_) { + my $new = shift; + $new =~ s/\?/%3F/g; + $bits[$elem] = $new; + $query = join("?",@bits); + $query =~ s/\?+$//; + $query = undef unless length($query); + $self->query($query); + } + + $old; +} + +sub dn { + my $old = shift->path(@_); + $old =~ s:^/::; + uri_unescape($old); +} + +sub attributes { + my $self = shift; + my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ()); + return $old unless wantarray; + map { uri_unescape($_) } split(/,/,$old); +} + +sub _scope { + my $self = shift; + my $old = _ldap_elem($self,1, @_); + return unless defined wantarray && defined $old; + uri_unescape($old); +} + +sub scope { + my $old = &_scope; + $old = "base" unless length $old; + $old; +} + +sub _filter { + my $self = shift; + my $old = _ldap_elem($self,2, @_); + return unless defined wantarray && defined $old; + uri_unescape($old); # || "(objectClass=*)"; +} + +sub filter { + my $old = &_filter; + $old = "(objectClass=*)" unless length $old; + $old; +} + +sub extensions { + my $self = shift; + my @ext; + while (@_) { + my $key = shift; + my $value = shift; + push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value)); + } + @ext = join(",", @ext) if @ext; + my $old = _ldap_elem($self,3, @ext); + return $old unless wantarray; + map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old); +} + +sub canonical +{ + my $self = shift; + my $other = $self->_nonldap_canonical; + + # The stuff below is not as efficient as one might hope... + + $other = $other->clone if $other == $self; + + $other->dn(_normalize_dn($other->dn)); + + # Should really know about mixed case "postalAddress", etc... + $other->attributes(map lc, $other->attributes); + + # Lowercase scope, remove default + my $old_scope = $other->scope; + my $new_scope = lc($old_scope); + $new_scope = "" if $new_scope eq "base"; + $other->scope($new_scope) if $new_scope ne $old_scope; + + # Remove filter if default + my $old_filter = $other->filter; + $other->filter("") if lc($old_filter) eq "(objectclass=*)" || + lc($old_filter) eq "objectclass=*"; + + # Lowercase extensions types and deal with known extension values + my @ext = $other->extensions; + for (my $i = 0; $i < @ext; $i += 2) { + my $etype = $ext[$i] = lc($ext[$i]); + if ($etype =~ /^!?bindname$/) { + $ext[$i+1] = _normalize_dn($ext[$i+1]); + } + } + $other->extensions(@ext) if @ext; + + $other; +} + +sub _normalize_dn # RFC 2253 +{ + my $dn = shift; + + return $dn; + # The code below will fail if the "+" or "," is embedding in a quoted + # string or simply escaped... + + my @dn = split(/([+,])/, $dn); + for (@dn) { + s/^([a-zA-Z]+=)/lc($1)/e; + } + join("", @dn); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_login.pm b/Master/tlpkg/tlperl/lib/URI/_login.pm new file mode 100644 index 00000000000..4583f20a9a6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_login.pm @@ -0,0 +1,10 @@ +package URI::_login; + +require URI::_server; +require URI::_userpass; +@ISA = qw(URI::_server URI::_userpass); + +# Generic terminal logins. This is used as a base class for 'telnet', +# 'tn3270', and 'rlogin' URL schemes. + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_punycode.pm b/Master/tlpkg/tlperl/lib/URI/_punycode.pm new file mode 100644 index 00000000000..828f176c3a8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_punycode.pm @@ -0,0 +1,202 @@ +package URI::_punycode; + +use strict; +our $VERSION = "0.03"; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(encode_punycode decode_punycode); + +use integer; + +our $DEBUG = 0; + +use constant BASE => 36; +use constant TMIN => 1; +use constant TMAX => 26; +use constant SKEW => 38; +use constant DAMP => 700; +use constant INITIAL_BIAS => 72; +use constant INITIAL_N => 128; + +my $Delimiter = chr 0x2D; +my $BasicRE = qr/[\x00-\x7f]/; + +sub _croak { require Carp; Carp::croak(@_); } + +sub digit_value { + my $code = shift; + return ord($code) - ord("A") if $code =~ /[A-Z]/; + return ord($code) - ord("a") if $code =~ /[a-z]/; + return ord($code) - ord("0") + 26 if $code =~ /[0-9]/; + return; +} + +sub code_point { + my $digit = shift; + return $digit + ord('a') if 0 <= $digit && $digit <= 25; + return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36; + die 'NOT COME HERE'; +} + +sub adapt { + my($delta, $numpoints, $firsttime) = @_; + $delta = $firsttime ? $delta / DAMP : $delta / 2; + $delta += $delta / $numpoints; + my $k = 0; + while ($delta > ((BASE - TMIN) * TMAX) / 2) { + $delta /= BASE - TMIN; + $k += BASE; + } + return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW)); +} + +sub decode_punycode { + my $code = shift; + + my $n = INITIAL_N; + my $i = 0; + my $bias = INITIAL_BIAS; + my @output; + + if ($code =~ s/(.*)$Delimiter//o) { + push @output, map ord, split //, $1; + return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o; + } + + while ($code) { + my $oldi = $i; + my $w = 1; + LOOP: + for (my $k = BASE; 1; $k += BASE) { + my $cp = substr($code, 0, 1, ''); + my $digit = digit_value($cp); + defined $digit or return _croak("invalid punycode input"); + $i += $digit * $w; + my $t = ($k <= $bias) ? TMIN + : ($k >= $bias + TMAX) ? TMAX : $k - $bias; + last LOOP if $digit < $t; + $w *= (BASE - $t); + } + $bias = adapt($i - $oldi, @output + 1, $oldi == 0); + warn "bias becomes $bias" if $DEBUG; + $n += $i / (@output + 1); + $i = $i % (@output + 1); + splice(@output, $i, 0, $n); + warn join " ", map sprintf('%04x', $_), @output if $DEBUG; + $i++; + } + return join '', map chr, @output; +} + +sub encode_punycode { + my $input = shift; + my @input = split //, $input; + + my $n = INITIAL_N; + my $delta = 0; + my $bias = INITIAL_BIAS; + + my @output; + my @basic = grep /$BasicRE/, @input; + my $h = my $b = @basic; + push @output, @basic; + push @output, $Delimiter if $b && $h < @input; + warn "basic codepoints: (@output)" if $DEBUG; + + while ($h < @input) { + my $m = min(grep { $_ >= $n } map ord, @input); + warn sprintf "next code point to insert is %04x", $m if $DEBUG; + $delta += ($m - $n) * ($h + 1); + $n = $m; + for my $i (@input) { + my $c = ord($i); + $delta++ if $c < $n; + if ($c == $n) { + my $q = $delta; + LOOP: + for (my $k = BASE; 1; $k += BASE) { + my $t = ($k <= $bias) ? TMIN : + ($k >= $bias + TMAX) ? TMAX : $k - $bias; + last LOOP if $q < $t; + my $cp = code_point($t + (($q - $t) % (BASE - $t))); + push @output, chr($cp); + $q = ($q - $t) / (BASE - $t); + } + push @output, chr(code_point($q)); + $bias = adapt($delta, $h + 1, $h == $b); + warn "bias becomes $bias" if $DEBUG; + $delta = 0; + $h++; + } + } + $delta++; + $n++; + } + return join '', @output; +} + +sub min { + my $min = shift; + for (@_) { $min = $_ if $_ <= $min } + return $min; +} + +1; +__END__ + +=head1 NAME + +URI::_punycode - encodes Unicode string in Punycode + +=head1 SYNOPSIS + + use URI::_punycode; + $punycode = encode_punycode($unicode); + $unicode = decode_punycode($punycode); + +=head1 DESCRIPTION + +URI::_punycode is a module to encode / decode Unicode strings into +Punycode, an efficient encoding of Unicode for use with IDNA. + +This module requires Perl 5.6.0 or over to handle UTF8 flagged Unicode +strings. + +=head1 FUNCTIONS + +This module exports following functions by default. + +=over 4 + +=item encode_punycode + + $punycode = encode_punycode($unicode); + +takes Unicode string (UTF8-flagged variable) and returns Punycode +encoding for it. + +=item decode_punycode + + $unicode = decode_punycode($punycode) + +takes Punycode encoding and returns original Unicode string. + +=back + +These functions throw exceptions on failure. You can catch 'em via +C<eval>. + +=head1 AUTHOR + +Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> is the author of +IDNA::Punycode v0.02 which was the basis for this module. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<IDNA::Punycode>, RFC 3492 + +=cut diff --git a/Master/tlpkg/tlperl/lib/URI/_query.pm b/Master/tlpkg/tlperl/lib/URI/_query.pm new file mode 100644 index 00000000000..0c6aa285e42 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_query.pm @@ -0,0 +1,92 @@ +package URI::_query; + +use strict; +use URI (); +use URI::Escape qw(uri_unescape); + +sub query +{ + my $self = shift; + $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die; + + if (@_) { + my $q = shift; + $$self = $1; + if (defined $q) { + $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; + $$self .= "?$q"; + } + $$self .= $3; + } + $2; +} + +# Handle ...?foo=bar&bar=foo type of query +sub query_form { + my $self = shift; + my $old = $self->query; + if (@_) { + # Try to set query string + my $delim; + my $r = $_[0]; + if (ref($r) eq "ARRAY") { + $delim = $_[1]; + @_ = @$r; + } + elsif (ref($r) eq "HASH") { + $delim = $_[1]; + @_ = %$r; + } + $delim = pop if @_ % 2; + + my @query; + while (my($key,$vals) = splice(@_, 0, 2)) { + $key = '' unless defined $key; + $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; + $key =~ s/ /+/g; + $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals]; + for my $val (@$vals) { + $val = '' unless defined $val; + $val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; + $val =~ s/ /+/g; + push(@query, "$key=$val"); + } + } + if (@query) { + unless ($delim) { + $delim = $1 if $old && $old =~ /([&;])/; + $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&"; + } + $self->query(join($delim, @query)); + } + else { + $self->query(undef); + } + } + return if !defined($old) || !length($old) || !defined(wantarray); + return unless $old =~ /=/; # not a form + map { s/\+/ /g; uri_unescape($_) } + map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old); +} + +# Handle ...?dog+bones type of query +sub query_keywords +{ + my $self = shift; + my $old = $self->query; + if (@_) { + # Try to set query string + my @copy = @_; + @copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY"; + for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; } + $self->query(@copy ? join('+', @copy) : undef); + } + return if !defined($old) || !defined(wantarray); + return if $old =~ /=/; # not keywords, but a form + map { uri_unescape($_) } split(/\+/, $old, -1); +} + +# Some URI::URL compatibility stuff +*equery = \&query; + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_segment.pm b/Master/tlpkg/tlperl/lib/URI/_segment.pm new file mode 100644 index 00000000000..c91b69608e3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_segment.pm @@ -0,0 +1,20 @@ +package URI::_segment; + +# Represents a generic path_segment so that it can be treated as +# a string too. + +use strict; +use URI::Escape qw(uri_unescape); + +use overload '""' => sub { $_[0]->[0] }, + fallback => 1; + +sub new +{ + my $class = shift; + my @segment = split(';', shift, -1); + $segment[0] = uri_unescape($segment[0]); + bless \@segment, $class; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_server.pm b/Master/tlpkg/tlperl/lib/URI/_server.pm new file mode 100644 index 00000000000..f72ec22657b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_server.pm @@ -0,0 +1,162 @@ +package URI::_server; +require URI::_generic; +@ISA=qw(URI::_generic); + +use strict; +use URI::Escape qw(uri_unescape); + +sub _uric_escape { + my($class, $str) = @_; + if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) { + my($scheme, $host, $rest) = ($1, $2, $3); + my $ui = $host =~ s/(.*@)// ? $1 : ""; + my $port = $host =~ s/(:\d+)\z// ? $1 : ""; + if (_host_escape($host)) { + $str = "$scheme//$ui$host$port$rest"; + } + } + return $class->SUPER::_uric_escape($str); +} + +sub _host_escape { + return unless $_[0] =~ /[^URI::uric]/; + eval { + require URI::_idna; + $_[0] = URI::_idna::encode($_[0]); + }; + return 0 if $@; + return 1; +} + +sub as_iri { + my $self = shift; + my $str = $self->SUPER::as_iri; + if ($str =~ /\bxn--/) { + if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) { + my($scheme, $host, $rest) = ($1, $2, $3); + my $ui = $host =~ s/(.*@)// ? $1 : ""; + my $port = $host =~ s/(:\d+)\z// ? $1 : ""; + require URI::_idna; + $host = URI::_idna::decode($host); + $str = "$scheme//$ui$host$port$rest"; + } + } + return $str; +} + +sub userinfo +{ + my $self = shift; + my $old = $self->authority; + + if (@_) { + my $new = $old; + $new = "" unless defined $new; + $new =~ s/.*@//; # remove old stuff + my $ui = shift; + if (defined $ui) { + $ui =~ s/@/%40/g; # protect @ + $new = "$ui\@$new"; + } + $self->authority($new); + } + return undef if !defined($old) || $old !~ /(.*)@/; + return $1; +} + +sub host +{ + my $self = shift; + my $old = $self->authority; + if (@_) { + my $tmp = $old; + $tmp = "" unless defined $tmp; + my $ui = ($tmp =~ /(.*@)/) ? $1 : ""; + my $port = ($tmp =~ /(:\d+)$/) ? $1 : ""; + my $new = shift; + $new = "" unless defined $new; + if (length $new) { + $new =~ s/[@]/%40/g; # protect @ + if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) { + $new =~ s/(:\d*)\z// || die "Assert"; + $port = $1; + } + $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address + _host_escape($new); + } + $self->authority("$ui$new$port"); + } + return undef unless defined $old; + $old =~ s/.*@//; + $old =~ s/:\d+$//; # remove the port + $old =~ s{^\[(.*)\]$}{$1}; # remove brackets around IPv6 (RFC 3986 3.2.2) + return uri_unescape($old); +} + +sub ihost +{ + my $self = shift; + my $old = $self->host(@_); + if ($old =~ /(^|\.)xn--/) { + require URI::_idna; + $old = URI::_idna::decode($old); + } + return $old; +} + +sub _port +{ + my $self = shift; + my $old = $self->authority; + if (@_) { + my $new = $old; + $new =~ s/:\d*$//; + my $port = shift; + $new .= ":$port" if defined $port; + $self->authority($new); + } + return $1 if defined($old) && $old =~ /:(\d*)$/; + return; +} + +sub port +{ + my $self = shift; + my $port = $self->_port(@_); + $port = $self->default_port if !defined($port) || $port eq ""; + $port; +} + +sub host_port +{ + my $self = shift; + my $old = $self->authority; + $self->host(shift) if @_; + return undef unless defined $old; + $old =~ s/.*@//; # zap userinfo + $old =~ s/:$//; # empty port should be treated the same a no port + $old .= ":" . $self->port unless $old =~ /:\d+$/; + $old; +} + + +sub default_port { undef } + +sub canonical +{ + my $self = shift; + my $other = $self->SUPER::canonical; + my $host = $other->host || ""; + my $port = $other->_port; + my $uc_host = $host =~ /[A-Z]/; + my $def_port = defined($port) && ($port eq "" || + $port == $self->default_port); + if ($uc_host || $def_port) { + $other = $other->clone if $other == $self; + $other->host(lc $host) if $uc_host; + $other->port(undef) if $def_port; + } + $other; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/_userpass.pm b/Master/tlpkg/tlperl/lib/URI/_userpass.pm new file mode 100644 index 00000000000..a0361ae0dd7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/_userpass.pm @@ -0,0 +1,51 @@ +package URI::_userpass; + +use strict; +use URI::Escape qw(uri_unescape); + +sub user +{ + my $self = shift; + my $info = $self->userinfo; + if (@_) { + my $new = shift; + my $pass = defined($info) ? $info : ""; + $pass =~ s/^[^:]*//; + + if (!defined($new) && !length($pass)) { + $self->userinfo(undef); + } else { + $new = "" unless defined($new); + $new =~ s/%/%25/g; + $new =~ s/:/%3A/g; + $self->userinfo("$new$pass"); + } + } + return unless defined $info; + $info =~ s/:.*//; + uri_unescape($info); +} + +sub password +{ + my $self = shift; + my $info = $self->userinfo; + if (@_) { + my $new = shift; + my $user = defined($info) ? $info : ""; + $user =~ s/:.*//; + + if (!defined($new) && !length($user)) { + $self->userinfo(undef); + } else { + $new = "" unless defined($new); + $new =~ s/%/%25/g; + $self->userinfo("$user:$new"); + } + } + return unless defined $info; + return unless $info =~ s/^[^:]*://; + uri_unescape($info); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/data.pm b/Master/tlpkg/tlperl/lib/URI/data.pm new file mode 100644 index 00000000000..dccd8181289 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/data.pm @@ -0,0 +1,140 @@ +package URI::data; # RFC 2397 + +require URI; +@ISA=qw(URI); + +use strict; + +use MIME::Base64 qw(encode_base64 decode_base64); +use URI::Escape qw(uri_unescape); + +sub media_type +{ + my $self = shift; + my $opaque = $self->opaque; + $opaque =~ /^([^,]*),?/ or die; + my $old = $1; + my $base64; + $base64 = $1 if $old =~ s/(;base64)$//i; + if (@_) { + my $new = shift; + $new = "" unless defined $new; + $new =~ s/%/%25/g; + $new =~ s/,/%2C/g; + $base64 = "" unless defined $base64; + $opaque =~ s/^[^,]*,?/$new$base64,/; + $self->opaque($opaque); + } + return uri_unescape($old) if $old; # media_type can't really be "0" + "text/plain;charset=US-ASCII"; # default type +} + +sub data +{ + my $self = shift; + my($enc, $data) = split(",", $self->opaque, 2); + unless (defined $data) { + $data = ""; + $enc = "" unless defined $enc; + } + my $base64 = ($enc =~ /;base64$/i); + if (@_) { + $enc =~ s/;base64$//i if $base64; + my $new = shift; + $new = "" unless defined $new; + my $uric_count = _uric_count($new); + my $urienc_len = $uric_count + (length($new) - $uric_count) * 3; + my $base64_len = int((length($new)+2) / 3) * 4; + $base64_len += 7; # because of ";base64" marker + if ($base64_len < $urienc_len || $_[0]) { + $enc .= ";base64"; + $new = encode_base64($new, ""); + } else { + $new =~ s/%/%25/g; + } + $self->opaque("$enc,$new"); + } + return unless defined wantarray; + $data = uri_unescape($data); + return $base64 ? decode_base64($data) : $data; +} + +# I could not find a better way to interpolate the tr/// chars from +# a variable. +my $ENC = $URI::uric; +$ENC =~ s/%//; + +eval <<EOT; die $@ if $@; +sub _uric_count +{ + \$_[0] =~ tr/$ENC//; +} +EOT + +1; + +__END__ + +=head1 NAME + +URI::data - URI that contains immediate data + +=head1 SYNOPSIS + + use URI; + + $u = URI->new("data:"); + $u->media_type("image/gif"); + $u->data(scalar(`cat camel.gif`)); + print "$u\n"; + open(XV, "|xv -") and print XV $u->data; + +=head1 DESCRIPTION + +The C<URI::data> class supports C<URI> objects belonging to the I<data> +URI scheme. The I<data> URI scheme is specified in RFC 2397. It +allows inclusion of small data items as "immediate" data, as if it had +been included externally. Examples: + + data:,Perl%20is%20good + + data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI + AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG + Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p + KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI + JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs= + + + +C<URI> objects belonging to the data scheme support the common methods +(described in L<URI>) and the following two scheme-specific methods: + +=over 4 + +=item $uri->media_type( [$new_media_type] ) + +Can be used to get or set the media type specified in the +URI. If no media type is specified, then the default +C<"text/plain;charset=US-ASCII"> is returned. + +=item $uri->data( [$new_data] ) + +Can be used to get or set the data contained in the URI. +The data is passed unescaped (in binary form). The decision about +whether to base64 encode the data in the URI is taken automatically, +based on the encoding that produces the shorter URI string. + +=back + +=head1 SEE ALSO + +L<URI> + +=head1 COPYRIGHT + +Copyright 1995-1998 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/URI/file.pm b/Master/tlpkg/tlperl/lib/URI/file.pm new file mode 100644 index 00000000000..59650607ea3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file.pm @@ -0,0 +1,328 @@ +package URI::file; + +use strict; +use vars qw(@ISA $VERSION $DEFAULT_AUTHORITY %OS_CLASS); + +require URI::_generic; +@ISA = qw(URI::_generic); +$VERSION = "4.20"; + +use URI::Escape qw(uri_unescape); + +$DEFAULT_AUTHORITY = ""; + +# Map from $^O values to implementation classes. The Unix +# class is the default. +%OS_CLASS = ( + os2 => "OS2", + mac => "Mac", + MacOS => "Mac", + MSWin32 => "Win32", + win32 => "Win32", + msdos => "FAT", + dos => "FAT", + qnx => "QNX", +); + +sub os_class +{ + my($OS) = shift || $^O; + + my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix"); + no strict 'refs'; + unless (%{"$class\::"}) { + eval "require $class"; + die $@ if $@; + } + $class; +} + +sub host { uri_unescape(shift->authority(@_)) } + +sub new +{ + my($class, $path, $os) = @_; + os_class($os)->new($path); +} + +sub new_abs +{ + my $class = shift; + my $file = $class->new(@_); + return $file->abs($class->cwd) unless $$file =~ /^file:/; + $file; +} + +sub cwd +{ + my $class = shift; + require Cwd; + my $cwd = Cwd::cwd(); + $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS'; + $cwd = $class->new($cwd); + $cwd .= "/" unless substr($cwd, -1, 1) eq "/"; + $cwd; +} + +sub canonical { + my $self = shift; + my $other = $self->SUPER::canonical; + + my $scheme = $other->scheme; + my $auth = $other->authority; + return $other if !defined($scheme) && !defined($auth); # relative + + if (!defined($auth) || + $auth eq "" || + lc($auth) eq "localhost" || + (defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY)) + ) + { + # avoid cloning if $auth already match + if ((defined($auth) || defined($DEFAULT_AUTHORITY)) && + (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY) + ) + { + $other = $other->clone if $self == $other; + $other->authority($DEFAULT_AUTHORITY); + } + } + + $other; +} + +sub file +{ + my($self, $os) = @_; + os_class($os)->file($self); +} + +sub dir +{ + my($self, $os) = @_; + os_class($os)->dir($self); +} + +1; + +__END__ + +=head1 NAME + +URI::file - URI that maps to local file names + +=head1 SYNOPSIS + + use URI::file; + + $u1 = URI->new("file:/foo/bar"); + $u2 = URI->new("foo/bar", "file"); + + $u3 = URI::file->new($path); + $u4 = URI::file->new("c:\\windows\\", "win32"); + + $u1->file; + $u1->file("mac"); + +=head1 DESCRIPTION + +The C<URI::file> class supports C<URI> objects belonging to the I<file> +URI scheme. This scheme allows us to map the conventional file names +found on various computer systems to the URI name space. An old +specification of the I<file> URI scheme is found in RFC 1738. Some +older background information is also in RFC 1630. There are no newer +specifications as far as I know. + +If you simply want to construct I<file> URI objects from URI strings, +use the normal C<URI> constructor. If you want to construct I<file> +URI objects from the actual file names used by various systems, then +use one of the following C<URI::file> constructors: + +=over 4 + +=item $u = URI::file->new( $filename, [$os] ) + +Maps a file name to the I<file:> URI name space, creates a URI object +and returns it. The $filename is interpreted as belonging to the +indicated operating system ($os), which defaults to the value of the +$^O variable. The $filename can be either absolute or relative, and +the corresponding type of URI object for $os is returned. + +=item $u = URI::file->new_abs( $filename, [$os] ) + +Same as URI::file->new, but makes sure that the URI returned +represents an absolute file name. If the $filename argument is +relative, then the name is resolved relative to the current directory, +i.e. this constructor is really the same as: + + URI::file->new($filename)->abs(URI::file->cwd); + +=item $u = URI::file->cwd + +Returns a I<file> URI that represents the current working directory. +See L<Cwd>. + +=back + +The following methods are supported for I<file> URI (in addition to +the common and generic methods described in L<URI>): + +=over 4 + +=item $u->file( [$os] ) + +Returns a file name. It maps from the URI name space +to the file name space of the indicated operating system. + +It might return C<undef> if the name can not be represented in the +indicated file system. + +=item $u->dir( [$os] ) + +Some systems use a different form for names of directories than for plain +files. Use this method if you know you want to use the name for +a directory. + +=back + +The C<URI::file> module can be used to map generic file names to names +suitable for the current system. As such, it can work as a nice +replacement for the C<File::Spec> module. For instance, the following +code translates the UNIX-style file name F<Foo/Bar.pm> to a name +suitable for the local system: + + $file = URI::file->new("Foo/Bar.pm", "unix")->file; + die "Can't map filename Foo/Bar.pm for $^O" unless defined $file; + open(FILE, $file) || die "Can't open '$file': $!"; + # do something with FILE + +=head1 MAPPING NOTES + +Most computer systems today have hierarchically organized file systems. +Mapping the names used in these systems to the generic URI syntax +allows us to work with relative file URIs that behave as they should +when resolved using the generic algorithm for URIs (specified in RFC +2396). Mapping a file name to the generic URI syntax involves mapping +the path separator character to "/" and encoding any reserved +characters that appear in the path segments of the file name. If +path segments consisting of the strings "." or ".." have a +different meaning than what is specified for generic URIs, then these +must be encoded as well. + +If the file system has device, volume or drive specifications as +the root of the name space, then it makes sense to map them to the +authority field of the generic URI syntax. This makes sure that +relative URIs can not be resolved "above" them, i.e. generally how +relative file names work in those systems. + +Another common use of the authority field is to encode the host on which +this file name is valid. The host name "localhost" is special and +generally has the same meaning as a missing or empty authority +field. This use is in conflict with using it as a device +specification, but can often be resolved for device specifications +having characters not legal in plain host names. + +File name to URI mapping in normally not one-to-one. There are +usually many URIs that map to any given file name. For instance, an +authority of "localhost" maps the same as a URI with a missing or empty +authority. + +Example 1: The Mac uses ":" as path separator, but not in the same way +as a generic URI. ":foo" is a relative name. "foo:bar" is an absolute +name. Also, path segments can contain the "/" character as well as the +literal "." or "..". So the mapping looks like this: + + Mac URI + ---------- ------------------- + :foo:bar <==> foo/bar + : <==> ./ + ::foo:bar <==> ../foo/bar + ::: <==> ../../ + foo:bar <==> file:/foo/bar + foo:bar: <==> file:/foo/bar/ + .. <==> %2E%2E + <undef> <== / + foo/ <== file:/foo%2F + ./foo.txt <== file:/.%2Ffoo.txt + +Note that if you want a relative URL, you *must* begin the path with a :. Any +path that begins with [^:] is treated as absolute. + +Example 2: The UNIX file system is easy to map, as it uses the same path +separator as URIs, has a single root, and segments of "." and ".." +have the same meaning. URIs that have the character "\0" or "/" as +part of any path segment can not be turned into valid UNIX file names. + + UNIX URI + ---------- ------------------ + foo/bar <==> foo/bar + /foo/bar <==> file:/foo/bar + /foo/bar <== file://localhost/foo/bar + file: ==> ./file: + <undef> <== file:/fo%00/bar + / <==> file:/ + +=cut + + +RFC 1630 + + [...] + + There is clearly a danger of confusion that a link made to a local + file should be followed by someone on a different system, with + unexpected and possibly harmful results. Therefore, the convention + is that even a "file" URL is provided with a host part. This allows + a client on another system to know that it cannot access the file + system, or perhaps to use some other local mechanism to access the + file. + + The special value "localhost" is used in the host field to indicate + that the filename should really be used on whatever host one is. + This for example allows links to be made to files which are + distributed on many machines, or to "your unix local password file" + subject of course to consistency across the users of the data. + + A void host field is equivalent to "localhost". + +=head1 CONFIGURATION VARIABLES + +The following configuration variables influence how the class and its +methods behave: + +=over + +=item %URI::file::OS_CLASS + +This hash maps OS identifiers to implementation classes. You might +want to add or modify this if you want to plug in your own file +handler class. Normally the keys should match the $^O values in use. + +If there is no mapping then the "Unix" implementation is used. + +=item $URI::file::DEFAULT_AUTHORITY + +This determine what "authority" string to include in absolute file +URIs. It defaults to "". If you prefer verbose URIs you might set it +to be "localhost". + +Setting this value to C<undef> force behaviour compatible to URI v1.31 +and earlier. In this mode host names in UNC paths and drive letters +are mapped to the authority component on Windows, while we produce +authority-less URIs on Unix. + +=back + + +=head1 SEE ALSO + +L<URI>, L<File::Spec>, L<perlport> + +=head1 COPYRIGHT + +Copyright 1995-1998,2004 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/URI/file/Base.pm b/Master/tlpkg/tlperl/lib/URI/file/Base.pm new file mode 100644 index 00000000000..941793b0f93 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file/Base.pm @@ -0,0 +1,80 @@ +package URI::file::Base; + +use strict; +use URI::Escape qw(); + +sub new +{ + my $class = shift; + my $path = shift; + $path = "" unless defined $path; + + my($auth, $escaped_auth, $escaped_path); + + ($auth, $escaped_auth) = $class->_file_extract_authority($path); + ($path, $escaped_path) = $class->_file_extract_path($path); + + if (defined $auth) { + $auth =~ s,%,%25,g unless $escaped_auth; + $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg; + $auth = "//$auth"; + if (defined $path) { + $path = "/$path" unless substr($path, 0, 1) eq "/"; + } else { + $path = ""; + } + } else { + return undef unless defined $path; + $auth = ""; + } + + $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path; + $path =~ s/\#/%23/g; + + my $uri = $auth . $path; + $uri = "file:$uri" if substr($uri, 0, 1) eq "/"; + + URI->new($uri, "file"); +} + +sub _file_extract_authority +{ + my($class, $path) = @_; + return undef unless $class->_file_is_absolute($path); + return $URI::file::DEFAULT_AUTHORITY; +} + +sub _file_extract_path +{ + return undef; +} + +sub _file_is_absolute +{ + return 0; +} + +sub _file_is_localhost +{ + shift; # class + my $host = lc(shift); + return 1 if $host eq "localhost"; + eval { + require Net::Domain; + lc(Net::Domain::hostfqdn()) eq $host || + lc(Net::Domain::hostname()) eq $host; + }; +} + +sub file +{ + undef; +} + +sub dir +{ + my $self = shift; + $self->file(@_); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/file/FAT.pm b/Master/tlpkg/tlperl/lib/URI/file/FAT.pm new file mode 100644 index 00000000000..328169bd0bf --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file/FAT.pm @@ -0,0 +1,23 @@ +package URI::file::FAT; + +require URI::file::Win32; +@ISA=qw(URI::file::Win32); + +sub fix_path +{ + shift; # class + for (@_) { + # turn it into 8.3 names + my @p = map uc, split(/\./, $_, -1); + return if @p > 2; # more than 1 dot is not allowed + @p = ("") unless @p; # split bug? (returns nothing when splitting "") + $_ = substr($p[0], 0, 8); + if (@p > 1) { + my $ext = substr($p[1], 0, 3); + $_ .= ".$ext" if length $ext; + } + } + 1; # ok +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/file/Mac.pm b/Master/tlpkg/tlperl/lib/URI/file/Mac.pm new file mode 100644 index 00000000000..6cfa78192e0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file/Mac.pm @@ -0,0 +1,120 @@ +package URI::file::Mac; + +require URI::file::Base; +@ISA=qw(URI::file::Base); + +use strict; +use URI::Escape qw(uri_unescape); + + + +sub _file_extract_path +{ + my $class = shift; + my $path = shift; + + my @pre; + if ($path =~ s/^(:+)//) { + if (length($1) == 1) { + @pre = (".") unless length($path); + } else { + @pre = ("..") x (length($1) - 1); + } + } else { #absolute + $pre[0] = ""; + } + + my $isdir = ($path =~ s/:$//); + $path =~ s,([%/;]), URI::Escape::escape_char($1),eg; + + my @path = split(/:/, $path, -1); + for (@path) { + if ($_ eq "." || $_ eq "..") { + $_ = "%2E" x length($_); + } + $_ = ".." unless length($_); + } + push (@path,"") if $isdir; + (join("/", @pre, @path), 1); +} + + +sub file +{ + my $class = shift; + my $uri = shift; + my @path; + + my $auth = $uri->authority; + if (defined $auth) { + if (lc($auth) ne "localhost" && $auth ne "") { + my $u_auth = uri_unescape($auth); + if (!$class->_file_is_localhost($u_auth)) { + # some other host (use it as volume name) + @path = ("", $auth); + # XXX or just return to make it illegal; + } + } + } + my @ps = split("/", $uri->path, -1); + shift @ps if @path; + push(@path, @ps); + + my $pre = ""; + if (!@path) { + return; # empty path; XXX return ":" instead? + } elsif ($path[0] eq "") { + # absolute + shift(@path); + if (@path == 1) { + return if $path[0] eq ""; # not root directory + push(@path, ""); # volume only, effectively append ":" + } + @ps = @path; + @path = (); + my $part; + for (@ps) { #fix up "." and "..", including interior, in relatives + next if $_ eq "."; + $part = $_ eq ".." ? "" : $_; + push(@path,$part); + } + if ($ps[-1] eq "..") { #if this happens, we need another : + push(@path,""); + } + + } else { + $pre = ":"; + @ps = @path; + @path = (); + my $part; + for (@ps) { #fix up "." and "..", including interior, in relatives + next if $_ eq "."; + $part = $_ eq ".." ? "" : $_; + push(@path,$part); + } + if ($ps[-1] eq "..") { #if this happens, we need another : + push(@path,""); + } + + } + return unless $pre || @path; + for (@path) { + s/;.*//; # get rid of parameters + #return unless length; # XXX + $_ = uri_unescape($_); + return if /\0/; + return if /:/; # Should we? + } + $pre . join(":", @path); +} + +sub dir +{ + my $class = shift; + my $path = $class->file(@_); + return unless defined $path; + $path .= ":" unless $path =~ /:$/; + $path; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/file/OS2.pm b/Master/tlpkg/tlperl/lib/URI/file/OS2.pm new file mode 100644 index 00000000000..ad0a78ede52 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file/OS2.pm @@ -0,0 +1,28 @@ +package URI::file::OS2; + +require URI::file::Win32; +@ISA=qw(URI::file::Win32); + +# The Win32 version translates k:/foo to file://k:/foo (?!) +# We add an empty host + +sub _file_extract_authority +{ + my $class = shift; + return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC + return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? + + if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) { # allow for ab: drives + return ""; + } + return; +} + +sub file { + my $p = &URI::file::Win32::file; + return unless defined $p; + $p =~ s,\\,/,g; + $p; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/file/QNX.pm b/Master/tlpkg/tlperl/lib/URI/file/QNX.pm new file mode 100644 index 00000000000..93a4983d2bb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file/QNX.pm @@ -0,0 +1,18 @@ +package URI::file::QNX; + +require URI::file::Unix; +@ISA=qw(URI::file::Unix); + +use strict; + +sub _file_extract_path +{ + my($class, $path) = @_; + # tidy path + $path =~ s,(.)//+,$1/,g; # ^// is correct + $path =~ s,(/\.)+/,/,g; + $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" + $path; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/file/Unix.pm b/Master/tlpkg/tlperl/lib/URI/file/Unix.pm new file mode 100644 index 00000000000..5f8aaae9050 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file/Unix.pm @@ -0,0 +1,55 @@ +package URI::file::Unix; + +require URI::file::Base; +@ISA=qw(URI::file::Base); + +use strict; +use URI::Escape qw(uri_unescape); + +sub _file_extract_path +{ + my($class, $path) = @_; + + # tidy path + $path =~ s,//+,/,g; + $path =~ s,(/\.)+/,/,g; + $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" + + return $path; +} + +sub _file_is_absolute { + my($class, $path) = @_; + return $path =~ m,^/,; +} + +sub file +{ + my $class = shift; + my $uri = shift; + my @path; + + my $auth = $uri->authority; + if (defined($auth)) { + if (lc($auth) ne "localhost" && $auth ne "") { + $auth = uri_unescape($auth); + unless ($class->_file_is_localhost($auth)) { + push(@path, "", "", $auth); + } + } + } + + my @ps = $uri->path_segments; + shift @ps if @path; + push(@path, @ps); + + for (@path) { + # Unix file/directory names are not allowed to contain '\0' or '/' + return undef if /\0/; + return undef if /\//; # should we really? + } + + return join("/", @path); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/file/Win32.pm b/Master/tlpkg/tlperl/lib/URI/file/Win32.pm new file mode 100644 index 00000000000..04593863a92 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/file/Win32.pm @@ -0,0 +1,84 @@ +package URI::file::Win32; + +require URI::file::Base; +@ISA=qw(URI::file::Base); + +use strict; +use URI::Escape qw(uri_unescape); + +sub _file_extract_authority +{ + my $class = shift; + + return $class->SUPER::_file_extract_authority($_[0]) + if defined $URI::file::DEFAULT_AUTHORITY; + + return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC + return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? + + if ($_[0] =~ s,^([a-zA-Z]:),,) { + my $auth = $1; + $auth .= "relative" if $_[0] !~ m,^[\\/],; + return $auth; + } + return undef; +} + +sub _file_extract_path +{ + my($class, $path) = @_; + $path =~ s,\\,/,g; + #$path =~ s,//+,/,g; + $path =~ s,(/\.)+/,/,g; + + if (defined $URI::file::DEFAULT_AUTHORITY) { + $path =~ s,^([a-zA-Z]:),/$1,; + } + + return $path; +} + +sub _file_is_absolute { + my($class, $path) = @_; + return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],; +} + +sub file +{ + my $class = shift; + my $uri = shift; + my $auth = $uri->authority; + my $rel; # is filename relative to drive specified in authority + if (defined $auth) { + $auth = uri_unescape($auth); + if ($auth =~ /^([a-zA-Z])[:|](relative)?/) { + $auth = uc($1) . ":"; + $rel++ if $2; + } elsif (lc($auth) eq "localhost") { + $auth = ""; + } elsif (length $auth) { + $auth = "\\\\" . $auth; # UNC + } + } else { + $auth = ""; + } + + my @path = $uri->path_segments; + for (@path) { + return undef if /\0/; + return undef if /\//; + #return undef if /\\/; # URLs with "\" is not uncommon + } + return undef unless $class->fix_path(@path); + + my $path = join("\\", @path); + $path =~ s/^\\// if $rel; + $path = $auth . $path; + $path =~ s,^\\([a-zA-Z])[:|],\u$1:,; + + return $path; +} + +sub fix_path { 1; } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/ftp.pm b/Master/tlpkg/tlperl/lib/URI/ftp.pm new file mode 100644 index 00000000000..89aeb07cdc9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/ftp.pm @@ -0,0 +1,45 @@ +package URI::ftp; + +require URI::_server; +require URI::_userpass; +@ISA=qw(URI::_server URI::_userpass); + +use strict; + +sub default_port { 21 } + +sub path { shift->path_query(@_) } # XXX + +sub _user { shift->SUPER::user(@_); } +sub _password { shift->SUPER::password(@_); } + +sub user +{ + my $self = shift; + my $user = $self->_user(@_); + $user = "anonymous" unless defined $user; + $user; +} + +sub password +{ + my $self = shift; + my $pass = $self->_password(@_); + unless (defined $pass) { + my $user = $self->user; + if ($user eq 'anonymous' || $user eq 'ftp') { + # anonymous ftp login password + # If there is no ftp anonymous password specified + # then we'll just use 'anonymous@' + # We don't try to send the read e-mail address because: + # - We want to remain anonymous + # - We want to stop SPAM + # - We don't want to let ftp sites to discriminate by the user, + # host, country or ftp client being used. + $pass = 'anonymous@'; + } + } + $pass; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/gopher.pm b/Master/tlpkg/tlperl/lib/URI/gopher.pm new file mode 100644 index 00000000000..ae6690423bc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/gopher.pm @@ -0,0 +1,94 @@ +package URI::gopher; # <draft-murali-url-gopher>, Dec 4, 1996 + +require URI::_server; +@ISA=qw(URI::_server); + +use strict; +use URI::Escape qw(uri_unescape); + +# A Gopher URL follows the common internet scheme syntax as defined in +# section 4.3 of [RFC-URL-SYNTAX]: +# +# gopher://<host>[:<port>]/<gopher-path> +# +# where +# +# <gopher-path> := <gopher-type><selector> | +# <gopher-type><selector>%09<search> | +# <gopher-type><selector>%09<search>%09<gopher+_string> +# +# <gopher-type> := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' +# '8' | '9' | '+' | 'I' | 'g' | 'T' +# +# <selector> := *pchar Refer to RFC 1808 [4] +# <search> := *pchar +# <gopher+_string> := *uchar Refer to RFC 1738 [3] +# +# If the optional port is omitted, the port defaults to 70. + +sub default_port { 70 } + +sub _gopher_type +{ + my $self = shift; + my $path = $self->path_query; + $path =~ s,^/,,; + my $gtype = $1 if $path =~ s/^(.)//s; + if (@_) { + my $new_type = shift; + if (defined($new_type)) { + Carp::croak("Bad gopher type '$new_type'") + unless length($new_type) == 1; + substr($path, 0, 0) = $new_type; + $self->path_query($path); + } else { + Carp::croak("Can't delete gopher type when selector is present") + if length($path); + $self->path_query(undef); + } + } + return $gtype; +} + +sub gopher_type +{ + my $self = shift; + my $gtype = $self->_gopher_type(@_); + $gtype = "1" unless defined $gtype; + $gtype; +} + +*gtype = \&gopher_type; # URI::URL compatibility + +sub selector { shift->_gfield(0, @_) } +sub search { shift->_gfield(1, @_) } +sub string { shift->_gfield(2, @_) } + +sub _gfield +{ + my $self = shift; + my $fno = shift; + my $path = $self->path_query; + + # not according to spec., but many popular browsers accept + # gopher URLs with a '?' before the search string. + $path =~ s/\?/\t/; + $path = uri_unescape($path); + $path =~ s,^/,,; + my $gtype = $1 if $path =~ s,^(.),,s; + my @path = split(/\t/, $path, 3); + if (@_) { + # modify + my $new = shift; + $path[$fno] = $new; + pop(@path) while @path && !defined($path[-1]); + for (@path) { $_="" unless defined } + $path = $gtype; + $path = "1" unless defined $path; + $path .= join("\t", @path); + $self->path_query($path); + } + $path[$fno]; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/http.pm b/Master/tlpkg/tlperl/lib/URI/http.pm new file mode 100644 index 00000000000..cb698224060 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/http.pm @@ -0,0 +1,25 @@ +package URI::http; + +require URI::_server; +@ISA=qw(URI::_server); + +use strict; + +sub default_port { 80 } + +sub canonical +{ + my $self = shift; + my $other = $self->SUPER::canonical; + + my $slash_path = defined($other->authority) && + !length($other->path) && !defined($other->query); + + if ($slash_path) { + $other = $other->clone if $other == $self; + $other->path("/"); + } + $other; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/https.pm b/Master/tlpkg/tlperl/lib/URI/https.pm new file mode 100644 index 00000000000..94f9bb19eb4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/https.pm @@ -0,0 +1,9 @@ +package URI::https; +require URI::http; +@ISA=qw(URI::http); + +sub default_port { 443 } + +sub secure { 1 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/ldap.pm b/Master/tlpkg/tlperl/lib/URI/ldap.pm new file mode 100644 index 00000000000..50acab4d1f5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/ldap.pm @@ -0,0 +1,122 @@ +# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package URI::ldap; + +use strict; + +use vars qw(@ISA $VERSION); +$VERSION = "1.11"; + +require URI::_server; +require URI::_ldap; +@ISA=qw(URI::_ldap URI::_server); + +sub default_port { 389 } + +sub _nonldap_canonical { + my $self = shift; + $self->URI::_server::canonical(@_); +} + +1; + +__END__ + +=head1 NAME + +URI::ldap - LDAP Uniform Resource Locators + +=head1 SYNOPSIS + + use URI; + + $uri = URI->new("ldap:$uri_string"); + $dn = $uri->dn; + $filter = $uri->filter; + @attr = $uri->attributes; + $scope = $uri->scope; + %extn = $uri->extensions; + + $uri = URI->new("ldap:"); # start empty + $uri->host("ldap.itd.umich.edu"); + $uri->dn("o=University of Michigan,c=US"); + $uri->attributes(qw(postalAddress)); + $uri->scope('sub'); + $uri->filter('(cn=Babs Jensen)'); + print $uri->as_string,"\n"; + +=head1 DESCRIPTION + +C<URI::ldap> provides an interface to parse an LDAP URI into its +constituent parts and also to build a URI as described in +RFC 2255. + +=head1 METHODS + +C<URI::ldap> supports all the generic and server methods defined by +L<URI>, plus the following. + +Each of the following methods can be used to set or get the value in +the URI. The values are passed in unescaped form. None of these +return undefined values, but elements without a default can be empty. +If arguments are given, then a new value is set for the given part +of the URI. + +=over 4 + +=item $uri->dn( [$new_dn] ) + +Sets or gets the I<Distinguished Name> part of the URI. The DN +identifies the base object of the LDAP search. + +=item $uri->attributes( [@new_attrs] ) + +Sets or gets the list of attribute names which are +returned by the search. + +=item $uri->scope( [$new_scope] ) + +Sets or gets the scope to be used by the search. The value can be one of +C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the +return value defaults to C<"base">. + +=item $uri->_scope( [$new_scope] ) + +Same as scope(), but does not default to anything. + +=item $uri->filter( [$new_filter] ) + +Sets or gets the filter to be used by the search. If none is given in +the URI then the return value defaults to C<"(objectClass=*)">. + +=item $uri->_filter( [$new_filter] ) + +Same as filter(), but does not default to anything. + +=item $uri->extensions( [$etype => $evalue,...] ) + +Sets or gets the extensions used for the search. The list passed should +be in the form etype1 => evalue1, etype2 => evalue2,... This is also +the form of list that is returned. + +=back + +=head1 SEE ALSO + +L<http://tools.ietf.org/html/rfc2255> + +=head1 AUTHOR + +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +Slightly modified by Gisle Aas to fit into the URI distribution. + +=head1 COPYRIGHT + +Copyright (c) 1998 Graham Barr. All rights reserved. This program 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/URI/ldapi.pm b/Master/tlpkg/tlperl/lib/URI/ldapi.pm new file mode 100644 index 00000000000..d92b13f3a49 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/ldapi.pm @@ -0,0 +1,30 @@ +package URI::ldapi; + +use strict; + +use vars qw(@ISA); + +require URI::_generic; +require URI::_ldap; +@ISA=qw(URI::_ldap URI::_generic); + +require URI::Escape; + +sub un_path { + my $self = shift; + my $old = URI::Escape::uri_unescape($self->authority); + if (@_) { + my $p = shift; + $p =~ s/:/%3A/g; + $p =~ s/\@/%40/g; + $self->authority($p); + } + return $old; +} + +sub _nonldap_canonical { + my $self = shift; + $self->URI::_generic::canonical(@_); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/ldaps.pm b/Master/tlpkg/tlperl/lib/URI/ldaps.pm new file mode 100644 index 00000000000..cbf901b11ca --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/ldaps.pm @@ -0,0 +1,9 @@ +package URI::ldaps; +require URI::ldap; +@ISA=qw(URI::ldap); + +sub default_port { 636 } + +sub secure { 1 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/mailto.pm b/Master/tlpkg/tlperl/lib/URI/mailto.pm new file mode 100644 index 00000000000..88761c40333 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/mailto.pm @@ -0,0 +1,72 @@ +package URI::mailto; # RFC 2368 + +require URI; +require URI::_query; +@ISA=qw(URI URI::_query); + +use strict; + +sub to +{ + my $self = shift; + my @old = $self->headers; + if (@_) { + my @new = @old; + # get rid of any other to: fields + for (my $i = 0; $i < @new; $i += 2) { + if (lc($new[$i] || '') eq "to") { + splice(@new, $i, 2); + redo; + } + } + + my $to = shift; + $to = "" unless defined $to; + unshift(@new, "to" => $to); + $self->headers(@new); + } + return unless defined wantarray; + + my @to; + while (@old) { + my $h = shift @old; + my $v = shift @old; + push(@to, $v) if lc($h) eq "to"; + } + join(",", @to); +} + + +sub headers +{ + my $self = shift; + + # The trick is to just treat everything as the query string... + my $opaque = "to=" . $self->opaque; + $opaque =~ s/\?/&/; + + if (@_) { + my @new = @_; + + # strip out any "to" fields + my @to; + for (my $i=0; $i < @new; $i += 2) { + if (lc($new[$i] || '') eq "to") { + push(@to, (splice(@new, $i, 2))[1]); # remove header + redo; + } + } + + my $new = join(",",@to); + $new =~ s/%/%25/g; + $new =~ s/\?/%3F/g; + $self->opaque($new); + $self->query_form(@new) if @new; + } + return unless defined wantarray; + + # I am lazy today... + URI->new("mailto:?$opaque")->query_form; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/mms.pm b/Master/tlpkg/tlperl/lib/URI/mms.pm new file mode 100644 index 00000000000..2f1015b61d9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/mms.pm @@ -0,0 +1,8 @@ +package URI::mms; + +require URI::http; +@ISA=qw(URI::http); + +sub default_port { 1755 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/news.pm b/Master/tlpkg/tlperl/lib/URI/news.pm new file mode 100644 index 00000000000..1ffb419f673 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/news.pm @@ -0,0 +1,68 @@ +package URI::news; # draft-gilman-news-url-01 + +require URI::_server; +@ISA=qw(URI::_server); + +use strict; +use URI::Escape qw(uri_unescape); +use Carp (); + +sub default_port { 119 } + +# newsURL = scheme ":" [ news-server ] [ refbygroup | message ] +# scheme = "news" | "snews" | "nntp" +# news-server = "//" server "/" +# refbygroup = group [ "/" messageno [ "-" messageno ] ] +# message = local-part "@" domain + +sub _group +{ + my $self = shift; + my $old = $self->path; + if (@_) { + my($group,$from,$to) = @_; + if ($group =~ /\@/) { + $group =~ s/^<(.*)>$/$1/; # "<" and ">" should not be part of it + } + $group =~ s,%,%25,g; + $group =~ s,/,%2F,g; + my $path = $group; + if (defined $from) { + $path .= "/$from"; + $path .= "-$to" if defined $to; + } + $self->path($path); + } + + $old =~ s,^/,,; + if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) { + my $extra = $1; + return (uri_unescape($old), split(/-/, $extra)); + } + uri_unescape($old); +} + + +sub group +{ + my $self = shift; + if (@_) { + Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/; + } + my @old = $self->_group(@_); + return if $old[0] =~ /\@/; + wantarray ? @old : $old[0]; +} + +sub message +{ + my $self = shift; + if (@_) { + Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/; + } + my $old = $self->_group(@_); + return unless $old =~ /\@/; + return $old; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/nntp.pm b/Master/tlpkg/tlperl/lib/URI/nntp.pm new file mode 100644 index 00000000000..af61e036cc7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/nntp.pm @@ -0,0 +1,6 @@ +package URI::nntp; # draft-gilman-news-url-01 + +require URI::news; +@ISA=qw(URI::news); + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/pop.pm b/Master/tlpkg/tlperl/lib/URI/pop.pm new file mode 100644 index 00000000000..50b8d6dd511 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/pop.pm @@ -0,0 +1,68 @@ +package URI::pop; # RFC 2384 + +require URI::_server; +@ISA=qw(URI::_server); + +use strict; +use URI::Escape qw(uri_unescape); + +sub default_port { 110 } + +#pop://<user>;auth=<auth>@<host>:<port> + +sub user +{ + my $self = shift; + my $old = $self->userinfo; + + if (@_) { + my $new_info = $old; + $new_info = "" unless defined $new_info; + $new_info =~ s/^[^;]*//; + + my $new = shift; + if (!defined($new) && !length($new_info)) { + $self->userinfo(undef); + } else { + $new = "" unless defined $new; + $new =~ s/%/%25/g; + $new =~ s/;/%3B/g; + $self->userinfo("$new$new_info"); + } + } + + return unless defined $old; + $old =~ s/;.*//; + return uri_unescape($old); +} + +sub auth +{ + my $self = shift; + my $old = $self->userinfo; + + if (@_) { + my $new = $old; + $new = "" unless defined $new; + $new =~ s/(^[^;]*)//; + my $user = $1; + $new =~ s/;auth=[^;]*//i; + + + my $auth = shift; + if (defined $auth) { + $auth =~ s/%/%25/g; + $auth =~ s/;/%3B/g; + $new = ";AUTH=$auth$new"; + } + $self->userinfo("$user$new"); + + } + + return unless defined $old; + $old =~ s/^[^;]*//; + return uri_unescape($1) if $old =~ /;auth=(.*)/i; + return; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/rlogin.pm b/Master/tlpkg/tlperl/lib/URI/rlogin.pm new file mode 100644 index 00000000000..18bb76272a4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/rlogin.pm @@ -0,0 +1,7 @@ +package URI::rlogin; +require URI::_login; +@ISA = qw(URI::_login); + +sub default_port { 513 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/rsync.pm b/Master/tlpkg/tlperl/lib/URI/rsync.pm new file mode 100644 index 00000000000..160d9d0c065 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/rsync.pm @@ -0,0 +1,12 @@ +package URI::rsync; # http://rsync.samba.org/ + +# rsync://[USER@]HOST[:PORT]/SRC + +require URI::_server; +require URI::_userpass; + +@ISA=qw(URI::_server URI::_userpass); + +sub default_port { 873 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/rtsp.pm b/Master/tlpkg/tlperl/lib/URI/rtsp.pm new file mode 100644 index 00000000000..982ca5ebf1e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/rtsp.pm @@ -0,0 +1,8 @@ +package URI::rtsp; + +require URI::http; +@ISA=qw(URI::http); + +sub default_port { 554 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/rtspu.pm b/Master/tlpkg/tlperl/lib/URI/rtspu.pm new file mode 100644 index 00000000000..dbcf12bb2f4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/rtspu.pm @@ -0,0 +1,8 @@ +package URI::rtspu; + +require URI::rtsp; +@ISA=qw(URI::rtsp); + +sub default_port { 554 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/sip.pm b/Master/tlpkg/tlperl/lib/URI/sip.pm new file mode 100644 index 00000000000..1ace52c4f58 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/sip.pm @@ -0,0 +1,86 @@ +# +# Written by Ryan Kereliuk <ryker@ryker.org>. This file may be +# distributed under the same terms as Perl itself. +# +# The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>. +# + +package URI::sip; + +require URI::_server; +require URI::_userpass; +@ISA=qw(URI::_server URI::_userpass); + +use strict; +use vars qw(@ISA $VERSION); +use URI::Escape qw(uri_unescape); + +$VERSION = "0.10"; + +sub default_port { 5060 } + +sub authority +{ + my $self = shift; + $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die; + my $old = $2; + + if (@_) { + my $auth = shift; + $$self = defined($1) ? $1 : ""; + my $rest = $3; + if (defined $auth) { + $auth =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; + $$self .= "$auth"; + } + $$self .= $rest; + } + $old; +} + +sub params_form +{ + my $self = shift; + $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; + my $paramstr = $3; + + if (@_) { + my @args = @_; + $$self = $1 . $2; + my $rest = $4; + my @new; + for (my $i=0; $i < @args; $i += 2) { + push(@new, "$args[$i]=$args[$i+1]"); + } + $paramstr = join(";", @new); + $$self .= ";" . $paramstr . $rest; + } + $paramstr =~ s/^;//o; + return split(/[;=]/, $paramstr); +} + +sub params +{ + my $self = shift; + $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; + my $paramstr = $3; + + if (@_) { + my $new = shift; + $$self = $1 . $2; + my $rest = $4; + $$self .= $paramstr . $rest; + } + $paramstr =~ s/^;//o; + return $paramstr; +} + +# Inherited methods that make no sense for a SIP URI. +sub path {} +sub path_query {} +sub path_segments {} +sub abs { shift } +sub rel { shift } +sub query_keywords {} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/sips.pm b/Master/tlpkg/tlperl/lib/URI/sips.pm new file mode 100644 index 00000000000..8d184a3d83b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/sips.pm @@ -0,0 +1,9 @@ +package URI::sips; +require URI::sip; +@ISA=qw(URI::sip); + +sub default_port { 5061 } + +sub secure { 1 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/snews.pm b/Master/tlpkg/tlperl/lib/URI/snews.pm new file mode 100644 index 00000000000..4310f8111a4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/snews.pm @@ -0,0 +1,10 @@ +package URI::snews; # draft-gilman-news-url-01 + +require URI::news; +@ISA=qw(URI::news); + +sub default_port { 563 } + +sub secure { 1 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/ssh.pm b/Master/tlpkg/tlperl/lib/URI/ssh.pm new file mode 100644 index 00000000000..1d47e4148f6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/ssh.pm @@ -0,0 +1,11 @@ +package URI::ssh; +require URI::_login; +@ISA=qw(URI::_login); + +# ssh://[USER@]HOST[:PORT]/SRC + +sub default_port { 22 } + +sub secure { 1 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/telnet.pm b/Master/tlpkg/tlperl/lib/URI/telnet.pm new file mode 100644 index 00000000000..5f842d35787 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/telnet.pm @@ -0,0 +1,7 @@ +package URI::telnet; +require URI::_login; +@ISA = qw(URI::_login); + +sub default_port { 23 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/tn3270.pm b/Master/tlpkg/tlperl/lib/URI/tn3270.pm new file mode 100644 index 00000000000..dd1e648e713 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/tn3270.pm @@ -0,0 +1,7 @@ +package URI::tn3270; +require URI::_login; +@ISA = qw(URI::_login); + +sub default_port { 23 } + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/urn.pm b/Master/tlpkg/tlperl/lib/URI/urn.pm new file mode 100644 index 00000000000..12d40b265bc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/urn.pm @@ -0,0 +1,97 @@ +package URI::urn; # RFC 2141 + +require URI; +@ISA=qw(URI); + +use strict; +use Carp qw(carp); + +use vars qw(%implementor); + +sub _init { + my $class = shift; + my $self = $class->SUPER::_init(@_); + my $nid = $self->nid; + + my $impclass = $implementor{$nid}; + return $impclass->_urn_init($self, $nid) if $impclass; + + $impclass = "URI::urn"; + if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) { + my $id = $nid; + # make it a legal perl identifier + $id =~ s/-/_/g; + $id = "_$id" if $id =~ /^\d/; + + $impclass = "URI::urn::$id"; + no strict 'refs'; + unless (@{"${impclass}::ISA"}) { + # Try to load it + eval "require $impclass"; + die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; + $impclass = "URI::urn" unless @{"${impclass}::ISA"}; + } + } + else { + carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W; + } + $implementor{$nid} = $impclass; + + return $impclass->_urn_init($self, $nid); +} + +sub _urn_init { + my($class, $self, $nid) = @_; + bless $self, $class; +} + +sub _nid { + my $self = shift; + my $opaque = $self->opaque; + if (@_) { + my $v = $opaque; + my $new = shift; + $v =~ s/[^:]*/$new/; + $self->opaque($v); + # XXX possible rebless + } + $opaque =~ s/:.*//s; + return $opaque; +} + +sub nid { # namespace identifier + my $self = shift; + my $nid = $self->_nid(@_); + $nid = lc($nid) if defined($nid); + return $nid; +} + +sub nss { # namespace specific string + my $self = shift; + my $opaque = $self->opaque; + if (@_) { + my $v = $opaque; + my $new = shift; + if (defined $new) { + $v =~ s/(:|\z).*/:$new/; + } + else { + $v =~ s/:.*//s; + } + $self->opaque($v); + } + return undef unless $opaque =~ s/^[^:]*://; + return $opaque; +} + +sub canonical { + my $self = shift; + my $nid = $self->_nid; + my $new = $self->SUPER::canonical; + return $new if $nid !~ /[A-Z]/ || $nid =~ /%/; + $new = $new->clone if $new == $self; + $new->nid(lc($nid)); + return $new; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/urn/isbn.pm b/Master/tlpkg/tlperl/lib/URI/urn/isbn.pm new file mode 100644 index 00000000000..0da931bfb69 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/urn/isbn.pm @@ -0,0 +1,102 @@ +package URI::urn::isbn; # RFC 3187 + +require URI::urn; +@ISA=qw(URI::urn); + +use strict; +use Carp qw(carp); + +BEGIN { + require Business::ISBN; + + local $^W = 0; # don't warn about dev versions, perl5.004 style + warn "Using Business::ISBN version " . Business::ISBN->VERSION . + " which is deprecated.\nUpgrade to Business::ISBN version 2\n" + if Business::ISBN->VERSION < 2; + } + +sub _isbn { + my $nss = shift; + $nss = $nss->nss if ref($nss); + my $isbn = Business::ISBN->new($nss); + $isbn = undef if $isbn && !$isbn->is_valid; + return $isbn; +} + +sub _nss_isbn { + my $self = shift; + my $nss = $self->nss(@_); + my $isbn = _isbn($nss); + $isbn = $isbn->as_string if $isbn; + return($nss, $isbn); +} + +sub isbn { + my $self = shift; + my $isbn; + (undef, $isbn) = $self->_nss_isbn(@_); + return $isbn; +} + +sub isbn_publisher_code { + my $isbn = shift->_isbn || return undef; + return $isbn->publisher_code; +} + +BEGIN { +my $group_method = do { + local $^W = 0; # don't warn about dev versions, perl5.004 style + Business::ISBN->VERSION >= 2 ? 'group_code' : 'country_code'; + }; + +sub isbn_group_code { + my $isbn = shift->_isbn || return undef; + return $isbn->$group_method; +} +} + +sub isbn_country_code { + my $name = (caller(0))[3]; $name =~ s/.*:://; + carp "$name is DEPRECATED. Use isbn_group_code instead"; + + no strict 'refs'; + &isbn_group_code; +} + +BEGIN { +my $isbn13_method = do { + local $^W = 0; # don't warn about dev versions, perl5.004 style + Business::ISBN->VERSION >= 2 ? 'as_isbn13' : 'as_ean'; + }; + +sub isbn13 { + my $isbn = shift->_isbn || return undef; + + # Business::ISBN 1.x didn't put hyphens in the EAN, and it was just a string + # Business::ISBN 2.0 doesn't do EAN, but it does ISBN-13 objects + # and it uses the hyphens, so call as_string with an empty anon array + # or, adjust the test and features to say that it comes out with hyphens. + my $thingy = $isbn->$isbn13_method; + return eval { $thingy->can( 'as_string' ) } ? $thingy->as_string([]) : $thingy; +} +} + +sub isbn_as_ean { + my $name = (caller(0))[3]; $name =~ s/.*:://; + carp "$name is DEPRECATED. Use isbn13 instead"; + + no strict 'refs'; + &isbn13; +} + +sub canonical { + my $self = shift; + my($nss, $isbn) = $self->_nss_isbn; + my $new = $self->SUPER::canonical; + return $new unless $nss && $isbn && $nss ne $isbn; + $new = $new->clone if $new == $self; + $new->nss($isbn); + return $new; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/URI/urn/oid.pm b/Master/tlpkg/tlperl/lib/URI/urn/oid.pm new file mode 100644 index 00000000000..301b2bcd834 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/urn/oid.pm @@ -0,0 +1,18 @@ +package URI::urn::oid; # RFC 2061 + +require URI::urn; +@ISA=qw(URI::urn); + +use strict; + +sub oid { + my $self = shift; + my $old = $self->nss; + if (@_) { + $self->nss(join(".", @_)); + } + return split(/\./, $old) if wantarray; + return $old; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/WWW/RobotRules.pm b/Master/tlpkg/tlperl/lib/WWW/RobotRules.pm new file mode 100644 index 00000000000..0b9fda3b768 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/WWW/RobotRules.pm @@ -0,0 +1,445 @@ +package WWW::RobotRules; + +$VERSION = "5.832"; +sub Version { $VERSION; } + +use strict; +use URI (); + + + +sub new { + my($class, $ua) = @_; + + # This ugly hack is needed to ensure backwards compatibility. + # The "WWW::RobotRules" class is now really abstract. + $class = "WWW::RobotRules::InCore" if $class eq "WWW::RobotRules"; + + my $self = bless { }, $class; + $self->agent($ua); + $self; +} + + +sub parse { + my($self, $robot_txt_uri, $txt, $fresh_until) = @_; + $robot_txt_uri = URI->new("$robot_txt_uri"); + my $netloc = $robot_txt_uri->host . ":" . $robot_txt_uri->port; + + $self->clear_rules($netloc); + $self->fresh_until($netloc, $fresh_until || (time + 365*24*3600)); + + my $ua; + my $is_me = 0; # 1 iff this record is for me + my $is_anon = 0; # 1 iff this record is for * + my $seen_disallow = 0; # watch for missing record separators + my @me_disallowed = (); # rules disallowed for me + my @anon_disallowed = (); # rules disallowed for * + + # blank lines are significant, so turn CRLF into LF to avoid generating + # false ones + $txt =~ s/\015\012/\012/g; + + # split at \012 (LF) or \015 (CR) (Mac text files have just CR for EOL) + for(split(/[\012\015]/, $txt)) { + + # Lines containing only a comment are discarded completely, and + # therefore do not indicate a record boundary. + next if /^\s*\#/; + + s/\s*\#.*//; # remove comments at end-of-line + + if (/^\s*$/) { # blank line + last if $is_me; # That was our record. No need to read the rest. + $is_anon = 0; + $seen_disallow = 0; + } + elsif (/^\s*User-Agent\s*:\s*(.*)/i) { + $ua = $1; + $ua =~ s/\s+$//; + + if ($seen_disallow) { + # treat as start of a new record + $seen_disallow = 0; + last if $is_me; # That was our record. No need to read the rest. + $is_anon = 0; + } + + if ($is_me) { + # This record already had a User-agent that + # we matched, so just continue. + } + elsif ($ua eq '*') { + $is_anon = 1; + } + elsif($self->is_me($ua)) { + $is_me = 1; + } + } + elsif (/^\s*Disallow\s*:\s*(.*)/i) { + unless (defined $ua) { + warn "RobotRules <$robot_txt_uri>: Disallow without preceding User-agent\n" if $^W; + $is_anon = 1; # assume that User-agent: * was intended + } + my $disallow = $1; + $disallow =~ s/\s+$//; + $seen_disallow = 1; + if (length $disallow) { + my $ignore; + eval { + my $u = URI->new_abs($disallow, $robot_txt_uri); + $ignore++ if $u->scheme ne $robot_txt_uri->scheme; + $ignore++ if lc($u->host) ne lc($robot_txt_uri->host); + $ignore++ if $u->port ne $robot_txt_uri->port; + $disallow = $u->path_query; + $disallow = "/" unless length $disallow; + }; + next if $@; + next if $ignore; + } + + if ($is_me) { + push(@me_disallowed, $disallow); + } + elsif ($is_anon) { + push(@anon_disallowed, $disallow); + } + } + elsif (/\S\s*:/) { + # ignore + } + else { + warn "RobotRules <$robot_txt_uri>: Malformed record: <$_>\n" if $^W; + } + } + + if ($is_me) { + $self->push_rules($netloc, @me_disallowed); + } + else { + $self->push_rules($netloc, @anon_disallowed); + } +} + + +# +# Returns TRUE if the given name matches the +# name of this robot +# +sub is_me { + my($self, $ua_line) = @_; + my $me = $self->agent; + + # See whether my short-name is a substring of the + # "User-Agent: ..." line that we were passed: + + if(index(lc($me), lc($ua_line)) >= 0) { + return 1; + } + else { + return ''; + } +} + + +sub allowed { + my($self, $uri) = @_; + $uri = URI->new("$uri"); + + return 1 unless $uri->scheme eq 'http' or $uri->scheme eq 'https'; + # Robots.txt applies to only those schemes. + + my $netloc = $uri->host . ":" . $uri->port; + + my $fresh_until = $self->fresh_until($netloc); + return -1 if !defined($fresh_until) || $fresh_until < time; + + my $str = $uri->path_query; + my $rule; + for $rule ($self->rules($netloc)) { + return 1 unless length $rule; + return 0 if index($str, $rule) == 0; + } + return 1; +} + + +# The following methods must be provided by the subclass. +sub agent; +sub visit; +sub no_visits; +sub last_visits; +sub fresh_until; +sub push_rules; +sub clear_rules; +sub rules; +sub dump; + + + +package WWW::RobotRules::InCore; + +use vars qw(@ISA); +@ISA = qw(WWW::RobotRules); + + + +sub agent { + my ($self, $name) = @_; + my $old = $self->{'ua'}; + if ($name) { + # Strip it so that it's just the short name. + # I.e., "FooBot" => "FooBot" + # "FooBot/1.2" => "FooBot" + # "FooBot/1.2 [http://foobot.int; foo@bot.int]" => "FooBot" + + $name = $1 if $name =~ m/(\S+)/; # get first word + $name =~ s!/.*!!; # get rid of version + unless ($old && $old eq $name) { + delete $self->{'loc'}; # all old info is now stale + $self->{'ua'} = $name; + } + } + $old; +} + + +sub visit { + my($self, $netloc, $time) = @_; + return unless $netloc; + $time ||= time; + $self->{'loc'}{$netloc}{'last'} = $time; + my $count = \$self->{'loc'}{$netloc}{'count'}; + if (!defined $$count) { + $$count = 1; + } + else { + $$count++; + } +} + + +sub no_visits { + my ($self, $netloc) = @_; + $self->{'loc'}{$netloc}{'count'}; +} + + +sub last_visit { + my ($self, $netloc) = @_; + $self->{'loc'}{$netloc}{'last'}; +} + + +sub fresh_until { + my ($self, $netloc, $fresh_until) = @_; + my $old = $self->{'loc'}{$netloc}{'fresh'}; + if (defined $fresh_until) { + $self->{'loc'}{$netloc}{'fresh'} = $fresh_until; + } + $old; +} + + +sub push_rules { + my($self, $netloc, @rules) = @_; + push (@{$self->{'loc'}{$netloc}{'rules'}}, @rules); +} + + +sub clear_rules { + my($self, $netloc) = @_; + delete $self->{'loc'}{$netloc}{'rules'}; +} + + +sub rules { + my($self, $netloc) = @_; + if (defined $self->{'loc'}{$netloc}{'rules'}) { + return @{$self->{'loc'}{$netloc}{'rules'}}; + } + else { + return (); + } +} + + +sub dump +{ + my $self = shift; + for (keys %$self) { + next if $_ eq 'loc'; + print "$_ = $self->{$_}\n"; + } + for (keys %{$self->{'loc'}}) { + my @rules = $self->rules($_); + print "$_: ", join("; ", @rules), "\n"; + } +} + + +1; + +__END__ + + +# Bender: "Well, I don't have anything else +# planned for today. Let's get drunk!" + +=head1 NAME + +WWW::RobotRules - database of robots.txt-derived permissions + +=head1 SYNOPSIS + + use WWW::RobotRules; + my $rules = WWW::RobotRules->new('MOMspider/1.0'); + + use LWP::Simple qw(get); + + { + my $url = "http://some.place/robots.txt"; + my $robots_txt = get $url; + $rules->parse($url, $robots_txt) if defined $robots_txt; + } + + { + my $url = "http://some.other.place/robots.txt"; + my $robots_txt = get $url; + $rules->parse($url, $robots_txt) if defined $robots_txt; + } + + # Now we can check if a URL is valid for those servers + # whose "robots.txt" files we've gotten and parsed: + if($rules->allowed($url)) { + $c = get $url; + ... + } + +=head1 DESCRIPTION + +This module parses F</robots.txt> files as specified in +"A Standard for Robot Exclusion", at +<http://www.robotstxt.org/wc/norobots.html> +Webmasters can use the F</robots.txt> file to forbid conforming +robots from accessing parts of their web site. + +The parsed files are kept in a WWW::RobotRules object, and this object +provides methods to check if access to a given URL is prohibited. The +same WWW::RobotRules object can be used for one or more parsed +F</robots.txt> files on any number of hosts. + +The following methods are provided: + +=over 4 + +=item $rules = WWW::RobotRules->new($robot_name) + +This is the constructor for WWW::RobotRules objects. The first +argument given to new() is the name of the robot. + +=item $rules->parse($robot_txt_url, $content, $fresh_until) + +The parse() method takes as arguments the URL that was used to +retrieve the F</robots.txt> file, and the contents of the file. + +=item $rules->allowed($uri) + +Returns TRUE if this robot is allowed to retrieve this URL. + +=item $rules->agent([$name]) + +Get/set the agent name. NOTE: Changing the agent name will clear the robots.txt +rules and expire times out of the cache. + +=back + +=head1 ROBOTS.TXT + +The format and semantics of the "/robots.txt" file are as follows +(this is an edited abstract of +<http://www.robotstxt.org/wc/norobots.html>): + +The file consists of one or more records separated by one or more +blank lines. Each record contains lines of the form + + <field-name>: <value> + +The field name is case insensitive. Text after the '#' character on a +line is ignored during parsing. This is used for comments. The +following <field-names> can be used: + +=over 3 + +=item User-Agent + +The value of this field is the name of the robot the record is +describing access policy for. If more than one I<User-Agent> field is +present the record describes an identical access policy for more than +one robot. At least one field needs to be present per record. If the +value is '*', the record describes the default access policy for any +robot that has not not matched any of the other records. + +The I<User-Agent> fields must occur before the I<Disallow> fields. If a +record contains a I<User-Agent> field after a I<Disallow> field, that +constitutes a malformed record. This parser will assume that a blank +line should have been placed before that I<User-Agent> field, and will +break the record into two. All the fields before the I<User-Agent> field +will constitute a record, and the I<User-Agent> field will be the first +field in a new record. + +=item Disallow + +The value of this field specifies a partial URL that is not to be +visited. This can be a full path, or a partial path; any URL that +starts with this value will not be retrieved + +=back + +Unrecognized records are ignored. + +=head1 ROBOTS.TXT EXAMPLES + +The following example "/robots.txt" file specifies that no robots +should visit any URL starting with "/cyberworld/map/" or "/tmp/": + + User-agent: * + Disallow: /cyberworld/map/ # This is an infinite virtual URL space + Disallow: /tmp/ # these will soon disappear + +This example "/robots.txt" file specifies that no robots should visit +any URL starting with "/cyberworld/map/", except the robot called +"cybermapper": + + User-agent: * + Disallow: /cyberworld/map/ # This is an infinite virtual URL space + + # Cybermapper knows where to go. + User-agent: cybermapper + Disallow: + +This example indicates that no robots should visit this site further: + + # go away + User-agent: * + Disallow: / + +This is an example of a malformed robots.txt file. + + # robots.txt for ancientcastle.example.com + # I've locked myself away. + User-agent: * + Disallow: / + # The castle is your home now, so you can go anywhere you like. + User-agent: Belle + Disallow: /west-wing/ # except the west wing! + # It's good to be the Prince... + User-agent: Beast + Disallow: + +This file is missing the required blank lines between records. +However, the intention is clear. + +=head1 SEE ALSO + +L<LWP::RobotUA>, L<WWW::RobotRules::AnyDBM_File> diff --git a/Master/tlpkg/tlperl/lib/WWW/RobotRules/AnyDBM_File.pm b/Master/tlpkg/tlperl/lib/WWW/RobotRules/AnyDBM_File.pm new file mode 100644 index 00000000000..145b4a8b13e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/WWW/RobotRules/AnyDBM_File.pm @@ -0,0 +1,170 @@ +package WWW::RobotRules::AnyDBM_File; + +require WWW::RobotRules; +@ISA = qw(WWW::RobotRules); +$VERSION = "5.835"; + +use Carp (); +use AnyDBM_File; +use Fcntl; +use strict; + +=head1 NAME + +WWW::RobotRules::AnyDBM_File - Persistent RobotRules + +=head1 SYNOPSIS + + require WWW::RobotRules::AnyDBM_File; + require LWP::RobotUA; + + # Create a robot useragent that uses a diskcaching RobotRules + my $rules = WWW::RobotRules::AnyDBM_File->new( 'my-robot/1.0', 'cachefile' ); + my $ua = WWW::RobotUA->new( 'my-robot/1.0', 'me@foo.com', $rules ); + + # Then just use $ua as usual + $res = $ua->request($req); + +=head1 DESCRIPTION + +This is a subclass of I<WWW::RobotRules> that uses the AnyDBM_File +package to implement persistent diskcaching of F<robots.txt> and host +visit information. + +The constructor (the new() method) takes an extra argument specifying +the name of the DBM file to use. If the DBM file already exists, then +you can specify undef as agent name as the name can be obtained from +the DBM database. + +=cut + +sub new +{ + my ($class, $ua, $file) = @_; + Carp::croak('WWW::RobotRules::AnyDBM_File filename required') unless $file; + + my $self = bless { }, $class; + $self->{'filename'} = $file; + tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_CREAT|O_RDWR, 0640 + or Carp::croak("Can't open $file: $!"); + + if ($ua) { + $self->agent($ua); + } + else { + # Try to obtain name from DBM file + $ua = $self->{'dbm'}{"|ua-name|"}; + Carp::croak("No agent name specified") unless $ua; + } + + $self; +} + +sub agent { + my($self, $newname) = @_; + my $old = $self->{'dbm'}{"|ua-name|"}; + if (defined $newname) { + $newname =~ s!/?\s*\d+.\d+\s*$!!; # loose version + unless ($old && $old eq $newname) { + # Old info is now stale. + my $file = $self->{'filename'}; + untie %{$self->{'dbm'}}; + tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_TRUNC|O_RDWR, 0640; + %{$self->{'dbm'}} = (); + $self->{'dbm'}{"|ua-name|"} = $newname; + } + } + $old; +} + +sub no_visits { + my ($self, $netloc) = @_; + my $t = $self->{'dbm'}{"$netloc|vis"}; + return 0 unless $t; + (split(/;\s*/, $t))[0]; +} + +sub last_visit { + my ($self, $netloc) = @_; + my $t = $self->{'dbm'}{"$netloc|vis"}; + return undef unless $t; + (split(/;\s*/, $t))[1]; +} + +sub fresh_until { + my ($self, $netloc, $fresh) = @_; + my $old = $self->{'dbm'}{"$netloc|exp"}; + if ($old) { + $old =~ s/;.*//; # remove cleartext + } + if (defined $fresh) { + $fresh .= "; " . localtime($fresh); + $self->{'dbm'}{"$netloc|exp"} = $fresh; + } + $old; +} + +sub visit { + my($self, $netloc, $time) = @_; + $time ||= time; + + my $count = 0; + my $old = $self->{'dbm'}{"$netloc|vis"}; + if ($old) { + my $last; + ($count,$last) = split(/;\s*/, $old); + $time = $last if $last > $time; + } + $count++; + $self->{'dbm'}{"$netloc|vis"} = "$count; $time; " . localtime($time); +} + +sub push_rules { + my($self, $netloc, @rules) = @_; + my $cnt = 1; + $cnt++ while $self->{'dbm'}{"$netloc|r$cnt"}; + + foreach (@rules) { + $self->{'dbm'}{"$netloc|r$cnt"} = $_; + $cnt++; + } +} + +sub clear_rules { + my($self, $netloc) = @_; + my $cnt = 1; + while ($self->{'dbm'}{"$netloc|r$cnt"}) { + delete $self->{'dbm'}{"$netloc|r$cnt"}; + $cnt++; + } +} + +sub rules { + my($self, $netloc) = @_; + my @rules = (); + my $cnt = 1; + while (1) { + my $rule = $self->{'dbm'}{"$netloc|r$cnt"}; + last unless $rule; + push(@rules, $rule); + $cnt++; + } + @rules; +} + +sub dump +{ +} + +1; + +=head1 SEE ALSO + +L<WWW::RobotRules>, L<LWP::RobotUA> + +=head1 AUTHORS + +Hakan Ardo E<lt>hakan@munin.ub2.lu.se>, Gisle Aas E<lt>aas@sn.no> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/auto/HTML/Parser/.packlist b/Master/tlpkg/tlperl/lib/auto/HTML/Parser/.packlist new file mode 100644 index 00000000000..cd7257dbe4a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/auto/HTML/Parser/.packlist @@ -0,0 +1,9 @@ +X:\perlnew\site\lib\HTML\Entities.pm
+X:\perlnew\site\lib\HTML\Filter.pm
+X:\perlnew\site\lib\HTML\HeadParser.pm
+X:\perlnew\site\lib\HTML\LinkExtor.pm
+X:\perlnew\site\lib\HTML\Parser.pm
+X:\perlnew\site\lib\HTML\PullParser.pm
+X:\perlnew\site\lib\HTML\TokeParser.pm
+X:\perlnew\site\lib\auto\HTML\Parser\Parser.bs
+X:\perlnew\site\lib\auto\HTML\Parser\Parser.dll
diff --git a/Master/tlpkg/tlperl/lib/auto/HTML/Parser/Parser.bs b/Master/tlpkg/tlperl/lib/auto/HTML/Parser/Parser.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/auto/HTML/Parser/Parser.bs diff --git a/Master/tlpkg/tlperl/lib/auto/HTML/Parser/Parser.dll b/Master/tlpkg/tlperl/lib/auto/HTML/Parser/Parser.dll Binary files differnew file mode 100644 index 00000000000..73d4a96a763 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/auto/HTML/Parser/Parser.dll diff --git a/Master/tlpkg/tlperl/lib/auto/HTML/Tagset/.packlist b/Master/tlpkg/tlperl/lib/auto/HTML/Tagset/.packlist new file mode 100644 index 00000000000..155ac35b1ab --- /dev/null +++ b/Master/tlpkg/tlperl/lib/auto/HTML/Tagset/.packlist @@ -0,0 +1 @@ +X:\perlnew\site\lib\HTML\Tagset.pm
diff --git a/Master/tlpkg/tlperl/lib/auto/LWP/.packlist b/Master/tlpkg/tlperl/lib/auto/LWP/.packlist new file mode 100644 index 00000000000..480c5744189 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/auto/LWP/.packlist @@ -0,0 +1,65 @@ +X:\perlnew\bin\lwp-download
+X:\perlnew\bin\lwp-download.bat
+X:\perlnew\bin\lwp-dump
+X:\perlnew\bin\lwp-dump.bat
+X:\perlnew\bin\lwp-mirror
+X:\perlnew\bin\lwp-mirror.bat
+X:\perlnew\bin\lwp-request
+X:\perlnew\bin\lwp-request.bat
+X:\perlnew\bin\lwp-rget
+X:\perlnew\bin\lwp-rget.bat
+X:\perlnew\site\lib\Bundle\LWP.pm
+X:\perlnew\site\lib\File\Listing.pm
+X:\perlnew\site\lib\HTML\Form.pm
+X:\perlnew\site\lib\HTTP\Config.pm
+X:\perlnew\site\lib\HTTP\Cookies.pm
+X:\perlnew\site\lib\HTTP\Cookies\Microsoft.pm
+X:\perlnew\site\lib\HTTP\Cookies\Netscape.pm
+X:\perlnew\site\lib\HTTP\Daemon.pm
+X:\perlnew\site\lib\HTTP\Date.pm
+X:\perlnew\site\lib\HTTP\Headers.pm
+X:\perlnew\site\lib\HTTP\Headers\Auth.pm
+X:\perlnew\site\lib\HTTP\Headers\ETag.pm
+X:\perlnew\site\lib\HTTP\Headers\Util.pm
+X:\perlnew\site\lib\HTTP\Message.pm
+X:\perlnew\site\lib\HTTP\Negotiate.pm
+X:\perlnew\site\lib\HTTP\Request.pm
+X:\perlnew\site\lib\HTTP\Request\Common.pm
+X:\perlnew\site\lib\HTTP\Response.pm
+X:\perlnew\site\lib\HTTP\Status.pm
+X:\perlnew\site\lib\LWP.pm
+X:\perlnew\site\lib\LWP\Authen\Basic.pm
+X:\perlnew\site\lib\LWP\Authen\Digest.pm
+X:\perlnew\site\lib\LWP\Authen\Ntlm.pm
+X:\perlnew\site\lib\LWP\ConnCache.pm
+X:\perlnew\site\lib\LWP\Debug.pm
+X:\perlnew\site\lib\LWP\DebugFile.pm
+X:\perlnew\site\lib\LWP\MediaTypes.pm
+X:\perlnew\site\lib\LWP\MemberMixin.pm
+X:\perlnew\site\lib\LWP\Protocol.pm
+X:\perlnew\site\lib\LWP\Protocol\GHTTP.pm
+X:\perlnew\site\lib\LWP\Protocol\cpan.pm
+X:\perlnew\site\lib\LWP\Protocol\data.pm
+X:\perlnew\site\lib\LWP\Protocol\file.pm
+X:\perlnew\site\lib\LWP\Protocol\ftp.pm
+X:\perlnew\site\lib\LWP\Protocol\gopher.pm
+X:\perlnew\site\lib\LWP\Protocol\http.pm
+X:\perlnew\site\lib\LWP\Protocol\http10.pm
+X:\perlnew\site\lib\LWP\Protocol\https.pm
+X:\perlnew\site\lib\LWP\Protocol\https10.pm
+X:\perlnew\site\lib\LWP\Protocol\loopback.pm
+X:\perlnew\site\lib\LWP\Protocol\mailto.pm
+X:\perlnew\site\lib\LWP\Protocol\nntp.pm
+X:\perlnew\site\lib\LWP\Protocol\nogo.pm
+X:\perlnew\site\lib\LWP\RobotUA.pm
+X:\perlnew\site\lib\LWP\Simple.pm
+X:\perlnew\site\lib\LWP\UserAgent.pm
+X:\perlnew\site\lib\LWP\media.types
+X:\perlnew\site\lib\Net\HTTP.pm
+X:\perlnew\site\lib\Net\HTTPS.pm
+X:\perlnew\site\lib\Net\HTTP\Methods.pm
+X:\perlnew\site\lib\Net\HTTP\NB.pm
+X:\perlnew\site\lib\WWW\RobotRules.pm
+X:\perlnew\site\lib\WWW\RobotRules\AnyDBM_File.pm
+X:\perlnew\site\lib\lwpcook.pod
+X:\perlnew\site\lib\lwptut.pod
diff --git a/Master/tlpkg/tlperl/lib/auto/URI/.packlist b/Master/tlpkg/tlperl/lib/auto/URI/.packlist new file mode 100644 index 00000000000..925fae2e8c1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/auto/URI/.packlist @@ -0,0 +1,52 @@ +X:\perlnew\site\lib\URI.pm
+X:\perlnew\site\lib\URI\Escape.pm
+X:\perlnew\site\lib\URI\Heuristic.pm
+X:\perlnew\site\lib\URI\IRI.pm
+X:\perlnew\site\lib\URI\QueryParam.pm
+X:\perlnew\site\lib\URI\Split.pm
+X:\perlnew\site\lib\URI\URL.pm
+X:\perlnew\site\lib\URI\WithBase.pm
+X:\perlnew\site\lib\URI\_foreign.pm
+X:\perlnew\site\lib\URI\_generic.pm
+X:\perlnew\site\lib\URI\_idna.pm
+X:\perlnew\site\lib\URI\_ldap.pm
+X:\perlnew\site\lib\URI\_login.pm
+X:\perlnew\site\lib\URI\_punycode.pm
+X:\perlnew\site\lib\URI\_query.pm
+X:\perlnew\site\lib\URI\_segment.pm
+X:\perlnew\site\lib\URI\_server.pm
+X:\perlnew\site\lib\URI\_userpass.pm
+X:\perlnew\site\lib\URI\data.pm
+X:\perlnew\site\lib\URI\file.pm
+X:\perlnew\site\lib\URI\file\Base.pm
+X:\perlnew\site\lib\URI\file\FAT.pm
+X:\perlnew\site\lib\URI\file\Mac.pm
+X:\perlnew\site\lib\URI\file\OS2.pm
+X:\perlnew\site\lib\URI\file\QNX.pm
+X:\perlnew\site\lib\URI\file\Unix.pm
+X:\perlnew\site\lib\URI\file\Win32.pm
+X:\perlnew\site\lib\URI\ftp.pm
+X:\perlnew\site\lib\URI\gopher.pm
+X:\perlnew\site\lib\URI\http.pm
+X:\perlnew\site\lib\URI\https.pm
+X:\perlnew\site\lib\URI\ldap.pm
+X:\perlnew\site\lib\URI\ldapi.pm
+X:\perlnew\site\lib\URI\ldaps.pm
+X:\perlnew\site\lib\URI\mailto.pm
+X:\perlnew\site\lib\URI\mms.pm
+X:\perlnew\site\lib\URI\news.pm
+X:\perlnew\site\lib\URI\nntp.pm
+X:\perlnew\site\lib\URI\pop.pm
+X:\perlnew\site\lib\URI\rlogin.pm
+X:\perlnew\site\lib\URI\rsync.pm
+X:\perlnew\site\lib\URI\rtsp.pm
+X:\perlnew\site\lib\URI\rtspu.pm
+X:\perlnew\site\lib\URI\sip.pm
+X:\perlnew\site\lib\URI\sips.pm
+X:\perlnew\site\lib\URI\snews.pm
+X:\perlnew\site\lib\URI\ssh.pm
+X:\perlnew\site\lib\URI\telnet.pm
+X:\perlnew\site\lib\URI\tn3270.pm
+X:\perlnew\site\lib\URI\urn.pm
+X:\perlnew\site\lib\URI\urn\isbn.pm
+X:\perlnew\site\lib\URI\urn\oid.pm
diff --git a/Master/tlpkg/tlperl/lib/lwpcook.pod b/Master/tlpkg/tlperl/lib/lwpcook.pod new file mode 100644 index 00000000000..172c819fe17 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/lwpcook.pod @@ -0,0 +1,309 @@ +=head1 NAME + +lwpcook - The libwww-perl cookbook + +=head1 DESCRIPTION + +This document contain some examples that show typical usage of the +libwww-perl library. You should consult the documentation for the +individual modules for more detail. + +All examples should be runnable programs. You can, in most cases, test +the code sections by piping the program text directly to perl. + + + +=head1 GET + +It is very easy to use this library to just fetch documents from the +net. The LWP::Simple module provides the get() function that return +the document specified by its URL argument: + + use LWP::Simple; + $doc = get 'http://www.linpro.no/lwp/'; + +or, as a perl one-liner using the getprint() function: + + perl -MLWP::Simple -e 'getprint "http://www.linpro.no/lwp/"' + +or, how about fetching the latest perl by running this command: + + perl -MLWP::Simple -e ' + getstore "ftp://ftp.sunet.se/pub/lang/perl/CPAN/src/latest.tar.gz", + "perl.tar.gz"' + +You will probably first want to find a CPAN site closer to you by +running something like the following command: + + perl -MLWP::Simple -e 'getprint "http://www.perl.com/perl/CPAN/CPAN.html"' + +Enough of this simple stuff! The LWP object oriented interface gives +you more control over the request sent to the server. Using this +interface you have full control over headers sent and how you want to +handle the response returned. + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $ua->agent("$0/0.1 " . $ua->agent); + # $ua->agent("Mozilla/8.0") # pretend we are very capable browser + + $req = HTTP::Request->new(GET => 'http://www.linpro.no/lwp'); + $req->header('Accept' => 'text/html'); + + # send request + $res = $ua->request($req); + + # check the outcome + if ($res->is_success) { + print $res->decoded_content; + } + else { + print "Error: " . $res->status_line . "\n"; + } + +The lwp-request program (alias GET) that is distributed with the +library can also be used to fetch documents from WWW servers. + + + +=head1 HEAD + +If you just want to check if a document is present (i.e. the URL is +valid) try to run code that looks like this: + + use LWP::Simple; + + if (head($url)) { + # ok document exists + } + +The head() function really returns a list of meta-information about +the document. The first three values of the list returned are the +document type, the size of the document, and the age of the document. + +More control over the request or access to all header values returned +require that you use the object oriented interface described for GET +above. Just s/GET/HEAD/g. + + +=head1 POST + +There is no simple procedural interface for posting data to a WWW server. You +must use the object oriented interface for this. The most common POST +operation is to access a WWW form application: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + + my $req = HTTP::Request->new(POST => 'http://www.perl.com/cgi-bin/BugGlimpse'); + $req->content_type('application/x-www-form-urlencoded'); + $req->content('match=www&errors=0'); + + my $res = $ua->request($req); + print $res->as_string; + +Lazy people use the HTTP::Request::Common module to set up a suitable +POST request message (it handles all the escaping issues) and has a +suitable default for the content_type: + + use HTTP::Request::Common qw(POST); + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + + my $req = POST 'http://www.perl.com/cgi-bin/BugGlimpse', + [ search => 'www', errors => 0 ]; + + print $ua->request($req)->as_string; + +The lwp-request program (alias POST) that is distributed with the +library can also be used for posting data. + + + +=head1 PROXIES + +Some sites use proxies to go through fire wall machines, or just as +cache in order to improve performance. Proxies can also be used for +accessing resources through protocols not supported directly (or +supported badly :-) by the libwww-perl library. + +You should initialize your proxy setting before you start sending +requests: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $ua->env_proxy; # initialize from environment variables + # or + $ua->proxy(ftp => 'http://proxy.myorg.com'); + $ua->proxy(wais => 'http://proxy.myorg.com'); + $ua->no_proxy(qw(no se fi)); + + my $req = HTTP::Request->new(GET => 'wais://xxx.com/'); + print $ua->request($req)->as_string; + +The LWP::Simple interface will call env_proxy() for you automatically. +Applications that use the $ua->env_proxy() method will normally not +use the $ua->proxy() and $ua->no_proxy() methods. + +Some proxies also require that you send it a username/password in +order to let requests through. You should be able to add the +required header, with something like this: + + use LWP::UserAgent; + + $ua = LWP::UserAgent->new; + $ua->proxy(['http', 'ftp'] => 'http://username:password@proxy.myorg.com'); + + $req = HTTP::Request->new('GET',"http://www.perl.com"); + + $res = $ua->request($req); + print $res->decoded_content if $res->is_success; + +Replace C<proxy.myorg.com>, C<username> and +C<password> with something suitable for your site. + + +=head1 ACCESS TO PROTECTED DOCUMENTS + +Documents protected by basic authorization can easily be accessed +like this: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $req = HTTP::Request->new(GET => 'http://www.linpro.no/secret/'); + $req->authorization_basic('aas', 'mypassword'); + print $ua->request($req)->as_string; + +The other alternative is to provide a subclass of I<LWP::UserAgent> that +overrides the get_basic_credentials() method. Study the I<lwp-request> +program for an example of this. + + +=head1 COOKIES + +Some sites like to play games with cookies. By default LWP ignores +cookies provided by the servers it visits. LWP will collect cookies +and respond to cookie requests if you set up a cookie jar. + + use LWP::UserAgent; + use HTTP::Cookies; + + $ua = LWP::UserAgent->new; + $ua->cookie_jar(HTTP::Cookies->new(file => "lwpcookies.txt", + autosave => 1)); + + # and then send requests just as you used to do + $res = $ua->request(HTTP::Request->new(GET => "http://www.yahoo.no")); + print $res->status_line, "\n"; + +As you visit sites that send you cookies to keep, then the file +F<lwpcookies.txt"> will grow. + +=head1 HTTPS + +URLs with https scheme are accessed in exactly the same way as with +http scheme, provided that an SSL interface module for LWP has been +properly installed (see the F<README.SSL> file found in the +libwww-perl distribution for more details). If no SSL interface is +installed for LWP to use, then you will get "501 Protocol scheme +'https' is not supported" errors when accessing such URLs. + +Here's an example of fetching and printing a WWW page using SSL: + + use LWP::UserAgent; + + my $ua = LWP::UserAgent->new; + my $req = HTTP::Request->new(GET => 'https://www.helsinki.fi/'); + my $res = $ua->request($req); + if ($res->is_success) { + print $res->as_string; + } + else { + print "Failed: ", $res->status_line, "\n"; + } + +=head1 MIRRORING + +If you want to mirror documents from a WWW server, then try to run +code similar to this at regular intervals: + + use LWP::Simple; + + %mirrors = ( + 'http://www.sn.no/' => 'sn.html', + 'http://www.perl.com/' => 'perl.html', + 'http://www.sn.no/libwww-perl/' => 'lwp.html', + 'gopher://gopher.sn.no/' => 'gopher.html', + ); + + while (($url, $localfile) = each(%mirrors)) { + mirror($url, $localfile); + } + +Or, as a perl one-liner: + + perl -MLWP::Simple -e 'mirror("http://www.perl.com/", "perl.html")'; + +The document will not be transferred unless it has been updated. + + + +=head1 LARGE DOCUMENTS + +If the document you want to fetch is too large to be kept in memory, +then you have two alternatives. You can instruct the library to write +the document content to a file (second $ua->request() argument is a file +name): + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + + my $req = HTTP::Request->new(GET => + 'http://www.linpro.no/lwp/libwww-perl-5.46.tar.gz'); + $res = $ua->request($req, "libwww-perl.tar.gz"); + if ($res->is_success) { + print "ok\n"; + } + else { + print $res->status_line, "\n"; + } + + +Or you can process the document as it arrives (second $ua->request() +argument is a code reference): + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $URL = 'ftp://ftp.unit.no/pub/rfc/rfc-index.txt'; + + my $expected_length; + my $bytes_received = 0; + my $res = + $ua->request(HTTP::Request->new(GET => $URL), + sub { + my($chunk, $res) = @_; + $bytes_received += length($chunk); + unless (defined $expected_length) { + $expected_length = $res->content_length || 0; + } + if ($expected_length) { + printf STDERR "%d%% - ", + 100 * $bytes_received / $expected_length; + } + print STDERR "$bytes_received bytes received\n"; + + # XXX Should really do something with the chunk itself + # print $chunk; + }); + print $res->status_line, "\n"; + + + +=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. + + diff --git a/Master/tlpkg/tlperl/lib/lwptut.pod b/Master/tlpkg/tlperl/lib/lwptut.pod new file mode 100644 index 00000000000..34bd58e5e96 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/lwptut.pod @@ -0,0 +1,839 @@ +=head1 NAME + +lwptut -- An LWP Tutorial + +=head1 DESCRIPTION + +LWP (short for "Library for WWW in Perl") is a very popular group of +Perl modules for accessing data on the Web. Like most Perl +module-distributions, each of LWP's component modules comes with +documentation that is a complete reference to its interface. However, +there are so many modules in LWP that it's hard to know where to start +looking for information on how to do even the simplest most common +things. + +Really introducing you to using LWP would require a whole book -- a book +that just happens to exist, called I<Perl & LWP>. But this article +should give you a taste of how you can go about some common tasks with +LWP. + + +=head2 Getting documents with LWP::Simple + +If you just want to get what's at a particular URL, the simplest way +to do it is LWP::Simple's functions. + +In a Perl program, you can call its C<get($url)> function. It will try +getting that URL's content. If it works, then it'll return the +content; but if there's some error, it'll return undef. + + my $url = 'http://freshair.npr.org/dayFA.cfm?todayDate=current'; + # Just an example: the URL for the most recent /Fresh Air/ show + + use LWP::Simple; + my $content = get $url; + die "Couldn't get $url" unless defined $content; + + # Then go do things with $content, like this: + + if($content =~ m/jazz/i) { + print "They're talking about jazz today on Fresh Air!\n"; + } + else { + print "Fresh Air is apparently jazzless today.\n"; + } + +The handiest variant on C<get> is C<getprint>, which is useful in Perl +one-liners. If it can get the page whose URL you provide, it sends it +to STDOUT; otherwise it complains to STDERR. + + % perl -MLWP::Simple -e "getprint 'http://cpan.org/RECENT'" + +That is the URL of a plain text file that lists new files in CPAN in +the past two weeks. You can easily make it part of a tidy little +shell command, like this one that mails you the list of new +C<Acme::> modules: + + % perl -MLWP::Simple -e "getprint 'http://cpan.org/RECENT'" \ + | grep "/by-module/Acme" | mail -s "New Acme modules! Joy!" $USER + +There are other useful functions in LWP::Simple, including one function +for running a HEAD request on a URL (useful for checking links, or +getting the last-revised time of a URL), and two functions for +saving/mirroring a URL to a local file. See L<the LWP::Simple +documentation|LWP::Simple> for the full details, or chapter 2 of I<Perl +& LWP> for more examples. + + + +=for comment + ########################################################################## + + + +=head2 The Basics of the LWP Class Model + +LWP::Simple's functions are handy for simple cases, but its functions +don't support cookies or authorization, don't support setting header +lines in the HTTP request, generally don't support reading header lines +in the HTTP response (notably the full HTTP error message, in case of an +error). To get at all those features, you'll have to use the full LWP +class model. + +While LWP consists of dozens of classes, the main two that you have to +understand are L<LWP::UserAgent> and L<HTTP::Response>. LWP::UserAgent +is a class for "virtual browsers" which you use for performing requests, +and L<HTTP::Response> is a class for the responses (or error messages) +that you get back from those requests. + +The basic idiom is C<< $response = $browser->get($url) >>, or more fully +illustrated: + + # Early in your program: + + use LWP 5.64; # Loads all important LWP classes, and makes + # sure your version is reasonably recent. + + my $browser = LWP::UserAgent->new; + + ... + + # Then later, whenever you need to make a get request: + my $url = 'http://freshair.npr.org/dayFA.cfm?todayDate=current'; + + my $response = $browser->get( $url ); + die "Can't get $url -- ", $response->status_line + unless $response->is_success; + + die "Hey, I was expecting HTML, not ", $response->content_type + unless $response->content_type eq 'text/html'; + # or whatever content-type you're equipped to deal with + + # Otherwise, process the content somehow: + + if($response->decoded_content =~ m/jazz/i) { + print "They're talking about jazz today on Fresh Air!\n"; + } + else { + print "Fresh Air is apparently jazzless today.\n"; + } + +There are two objects involved: C<$browser>, which holds an object of +class LWP::UserAgent, and then the C<$response> object, which is of +class HTTP::Response. You really need only one browser object per +program; but every time you make a request, you get back a new +HTTP::Response object, which will have some interesting attributes: + +=over + +=item * + +A status code indicating +success or failure +(which you can test with C<< $response->is_success >>). + +=item * + +An HTTP status +line that is hopefully informative if there's failure (which you can +see with C<< $response->status_line >>, +returning something like "404 Not Found"). + +=item * + +A MIME content-type like "text/html", "image/gif", +"application/xml", etc., which you can see with +C<< $response->content_type >> + +=item * + +The actual content of the response, in C<< $response->decoded_content >>. +If the response is HTML, that's where the HTML source will be; if +it's a GIF, then C<< $response->decoded_content >> will be the binary +GIF data. + +=item * + +And dozens of other convenient and more specific methods that are +documented in the docs for L<HTTP::Response>, and its superclasses +L<HTTP::Message> and L<HTTP::Headers>. + +=back + + + +=for comment + ########################################################################## + + + +=head2 Adding Other HTTP Request Headers + +The most commonly used syntax for requests is C<< $response = +$browser->get($url) >>, but in truth, you can add extra HTTP header +lines to the request by adding a list of key-value pairs after the URL, +like so: + + $response = $browser->get( $url, $key1, $value1, $key2, $value2, ... ); + +For example, here's how to send some more Netscape-like headers, in case +you're dealing with a site that would otherwise reject your request: + + + my @ns_headers = ( + 'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)', + 'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*', + 'Accept-Charset' => 'iso-8859-1,*,utf-8', + 'Accept-Language' => 'en-US', + ); + + ... + + $response = $browser->get($url, @ns_headers); + +If you weren't reusing that array, you could just go ahead and do this: + + $response = $browser->get($url, + 'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)', + 'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*', + 'Accept-Charset' => 'iso-8859-1,*,utf-8', + 'Accept-Language' => 'en-US', + ); + +If you were only ever changing the 'User-Agent' line, you could just change +the C<$browser> object's default line from "libwww-perl/5.65" (or the like) +to whatever you like, using the LWP::UserAgent C<agent> method: + + $browser->agent('Mozilla/4.76 [en] (Win98; U)'); + + + +=for comment + ########################################################################## + + + +=head2 Enabling Cookies + +A default LWP::UserAgent object acts like a browser with its cookies +support turned off. There are various ways of turning it on, by setting +its C<cookie_jar> attribute. A "cookie jar" is an object representing +a little database of all +the HTTP cookies that a browser can know about. It can correspond to a +file on disk (the way Netscape uses its F<cookies.txt> file), or it can +be just an in-memory object that starts out empty, and whose collection of +cookies will disappear once the program is finished running. + +To give a browser an in-memory empty cookie jar, you set its C<cookie_jar> +attribute like so: + + $browser->cookie_jar({}); + +To give it a copy that will be read from a file on disk, and will be saved +to it when the program is finished running, set the C<cookie_jar> attribute +like this: + + use HTTP::Cookies; + $browser->cookie_jar( HTTP::Cookies->new( + 'file' => '/some/where/cookies.lwp', + # where to read/write cookies + 'autosave' => 1, + # save it to disk when done + )); + +That file will be an LWP-specific format. If you want to be access the +cookies in your Netscape cookies file, you can use the +HTTP::Cookies::Netscape class: + + use HTTP::Cookies; + # yes, loads HTTP::Cookies::Netscape too + + $browser->cookie_jar( HTTP::Cookies::Netscape->new( + 'file' => 'c:/Program Files/Netscape/Users/DIR-NAME-HERE/cookies.txt', + # where to read cookies + )); + +You could add an C<< 'autosave' => 1 >> line as further above, but at +time of writing, it's uncertain whether Netscape might discard some of +the cookies you could be writing back to disk. + + + +=for comment + ########################################################################## + + + +=head2 Posting Form Data + +Many HTML forms send data to their server using an HTTP POST request, which +you can send with this syntax: + + $response = $browser->post( $url, + [ + formkey1 => value1, + formkey2 => value2, + ... + ], + ); + +Or if you need to send HTTP headers: + + $response = $browser->post( $url, + [ + formkey1 => value1, + formkey2 => value2, + ... + ], + headerkey1 => value1, + headerkey2 => value2, + ); + +For example, the following program makes a search request to AltaVista +(by sending some form data via an HTTP POST request), and extracts from +the HTML the report of the number of matches: + + use strict; + use warnings; + use LWP 5.64; + my $browser = LWP::UserAgent->new; + + my $word = 'tarragon'; + + my $url = 'http://www.altavista.com/sites/search/web'; + my $response = $browser->post( $url, + [ 'q' => $word, # the Altavista query string + 'pg' => 'q', 'avkw' => 'tgz', 'kl' => 'XX', + ] + ); + die "$url error: ", $response->status_line + unless $response->is_success; + die "Weird content type at $url -- ", $response->content_type + unless $response->content_is_html; + + if( $response->decoded_content =~ m{AltaVista found ([0-9,]+) results} ) { + # The substring will be like "AltaVista found 2,345 results" + print "$word: $1\n"; + } + else { + print "Couldn't find the match-string in the response\n"; + } + + + +=for comment + ########################################################################## + + + +=head2 Sending GET Form Data + +Some HTML forms convey their form data not by sending the data +in an HTTP POST request, but by making a normal GET request with +the data stuck on the end of the URL. For example, if you went to +C<imdb.com> and ran a search on "Blade Runner", the URL you'd see +in your browser window would be: + + http://us.imdb.com/Tsearch?title=Blade%20Runner&restrict=Movies+and+TV + +To run the same search with LWP, you'd use this idiom, which involves +the URI class: + + use URI; + my $url = URI->new( 'http://us.imdb.com/Tsearch' ); + # makes an object representing the URL + + $url->query_form( # And here the form data pairs: + 'title' => 'Blade Runner', + 'restrict' => 'Movies and TV', + ); + + my $response = $browser->get($url); + +See chapter 5 of I<Perl & LWP> for a longer discussion of HTML forms +and of form data, and chapters 6 through 9 for a longer discussion of +extracting data from HTML. + + + +=head2 Absolutizing URLs + +The URI class that we just mentioned above provides all sorts of methods +for accessing and modifying parts of URLs (such as asking sort of URL it +is with C<< $url->scheme >>, and asking what host it refers to with C<< +$url->host >>, and so on, as described in L<the docs for the URI +class|URI>. However, the methods of most immediate interest +are the C<query_form> method seen above, and now the C<new_abs> method +for taking a probably-relative URL string (like "../foo.html") and getting +back an absolute URL (like "http://www.perl.com/stuff/foo.html"), as +shown here: + + use URI; + $abs = URI->new_abs($maybe_relative, $base); + +For example, consider this program that matches URLs in the HTML +list of new modules in CPAN: + + use strict; + use warnings; + use LWP; + my $browser = LWP::UserAgent->new; + + my $url = 'http://www.cpan.org/RECENT.html'; + my $response = $browser->get($url); + die "Can't get $url -- ", $response->status_line + unless $response->is_success; + + my $html = $response->decoded_content; + while( $html =~ m/<A HREF=\"(.*?)\"/g ) { + print "$1\n"; + } + +When run, it emits output that starts out something like this: + + MIRRORING.FROM + RECENT + RECENT.html + authors/00whois.html + authors/01mailrc.txt.gz + authors/id/A/AA/AASSAD/CHECKSUMS + ... + +However, if you actually want to have those be absolute URLs, you +can use the URI module's C<new_abs> method, by changing the C<while> +loop to this: + + while( $html =~ m/<A HREF=\"(.*?)\"/g ) { + print URI->new_abs( $1, $response->base ) ,"\n"; + } + +(The C<< $response->base >> method from L<HTTP::Message|HTTP::Message> +is for returning what URL +should be used for resolving relative URLs -- it's usually just +the same as the URL that you requested.) + +That program then emits nicely absolute URLs: + + http://www.cpan.org/MIRRORING.FROM + http://www.cpan.org/RECENT + http://www.cpan.org/RECENT.html + http://www.cpan.org/authors/00whois.html + http://www.cpan.org/authors/01mailrc.txt.gz + http://www.cpan.org/authors/id/A/AA/AASSAD/CHECKSUMS + ... + +See chapter 4 of I<Perl & LWP> for a longer discussion of URI objects. + +Of course, using a regexp to match hrefs is a bit simplistic, and for +more robust programs, you'll probably want to use an HTML-parsing module +like L<HTML::LinkExtor> or L<HTML::TokeParser> or even maybe +L<HTML::TreeBuilder>. + + + + +=for comment + ########################################################################## + +=head2 Other Browser Attributes + +LWP::UserAgent objects have many attributes for controlling how they +work. Here are a few notable ones: + +=over + +=item * + +C<< $browser->timeout(15); >> + +This sets this browser object to give up on requests that don't answer +within 15 seconds. + + +=item * + +C<< $browser->protocols_allowed( [ 'http', 'gopher'] ); >> + +This sets this browser object to not speak any protocols other than HTTP +and gopher. If it tries accessing any other kind of URL (like an "ftp:" +or "mailto:" or "news:" URL), then it won't actually try connecting, but +instead will immediately return an error code 500, with a message like +"Access to 'ftp' URIs has been disabled". + + +=item * + +C<< use LWP::ConnCache; $browser->conn_cache(LWP::ConnCache->new()); >> + +This tells the browser object to try using the HTTP/1.1 "Keep-Alive" +feature, which speeds up requests by reusing the same socket connection +for multiple requests to the same server. + + +=item * + +C<< $browser->agent( 'SomeName/1.23 (more info here maybe)' ) >> + +This changes how the browser object will identify itself in +the default "User-Agent" line is its HTTP requests. By default, +it'll send "libwww-perl/I<versionnumber>", like +"libwww-perl/5.65". You can change that to something more descriptive +like this: + + $browser->agent( 'SomeName/3.14 (contact@robotplexus.int)' ); + +Or if need be, you can go in disguise, like this: + + $browser->agent( 'Mozilla/4.0 (compatible; MSIE 5.12; Mac_PowerPC)' ); + + +=item * + +C<< push @{ $ua->requests_redirectable }, 'POST'; >> + +This tells this browser to obey redirection responses to POST requests +(like most modern interactive browsers), even though the HTTP RFC says +that should not normally be done. + + +=back + + +For more options and information, see L<the full documentation for +LWP::UserAgent|LWP::UserAgent>. + + + +=for comment + ########################################################################## + + + +=head2 Writing Polite Robots + +If you want to make sure that your LWP-based program respects F<robots.txt> +files and doesn't make too many requests too fast, you can use the LWP::RobotUA +class instead of the LWP::UserAgent class. + +LWP::RobotUA class is just like LWP::UserAgent, and you can use it like so: + + use LWP::RobotUA; + my $browser = LWP::RobotUA->new('YourSuperBot/1.34', 'you@yoursite.com'); + # Your bot's name and your email address + + my $response = $browser->get($url); + +But HTTP::RobotUA adds these features: + + +=over + +=item * + +If the F<robots.txt> on C<$url>'s server forbids you from accessing +C<$url>, then the C<$browser> object (assuming it's of class LWP::RobotUA) +won't actually request it, but instead will give you back (in C<$response>) a 403 error +with a message "Forbidden by robots.txt". That is, if you have this line: + + die "$url -- ", $response->status_line, "\nAborted" + unless $response->is_success; + +then the program would die with an error message like this: + + http://whatever.site.int/pith/x.html -- 403 Forbidden by robots.txt + Aborted at whateverprogram.pl line 1234 + +=item * + +If this C<$browser> object sees that the last time it talked to +C<$url>'s server was too recently, then it will pause (via C<sleep>) to +avoid making too many requests too often. How long it will pause for, is +by default one minute -- but you can control it with the C<< +$browser->delay( I<minutes> ) >> attribute. + +For example, this code: + + $browser->delay( 7/60 ); + +...means that this browser will pause when it needs to avoid talking to +any given server more than once every 7 seconds. + +=back + +For more options and information, see L<the full documentation for +LWP::RobotUA|LWP::RobotUA>. + + + + + +=for comment + ########################################################################## + +=head2 Using Proxies + +In some cases, you will want to (or will have to) use proxies for +accessing certain sites and/or using certain protocols. This is most +commonly the case when your LWP program is running (or could be running) +on a machine that is behind a firewall. + +To make a browser object use proxies that are defined in the usual +environment variables (C<HTTP_PROXY>, etc.), just call the C<env_proxy> +on a user-agent object before you go making any requests on it. +Specifically: + + use LWP::UserAgent; + my $browser = LWP::UserAgent->new; + + # And before you go making any requests: + $browser->env_proxy; + +For more information on proxy parameters, see L<the LWP::UserAgent +documentation|LWP::UserAgent>, specifically the C<proxy>, C<env_proxy>, +and C<no_proxy> methods. + + + +=for comment + ########################################################################## + +=head2 HTTP Authentication + +Many web sites restrict access to documents by using "HTTP +Authentication". This isn't just any form of "enter your password" +restriction, but is a specific mechanism where the HTTP server sends the +browser an HTTP code that says "That document is part of a protected +'realm', and you can access it only if you re-request it and add some +special authorization headers to your request". + +For example, the Unicode.org admins stop email-harvesting bots from +harvesting the contents of their mailing list archives, by protecting +them with HTTP Authentication, and then publicly stating the username +and password (at C<http://www.unicode.org/mail-arch/>) -- namely +username "unicode-ml" and password "unicode". + +For example, consider this URL, which is part of the protected +area of the web site: + + http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html + +If you access that with a browser, you'll get a prompt +like +"Enter username and password for 'Unicode-MailList-Archives' at server +'www.unicode.org'". + +In LWP, if you just request that URL, like this: + + use LWP; + my $browser = LWP::UserAgent->new; + + my $url = + 'http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html'; + my $response = $browser->get($url); + + die "Error: ", $response->header('WWW-Authenticate') || 'Error accessing', + # ('WWW-Authenticate' is the realm-name) + "\n ", $response->status_line, "\n at $url\n Aborting" + unless $response->is_success; + +Then you'll get this error: + + Error: Basic realm="Unicode-MailList-Archives" + 401 Authorization Required + at http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html + Aborting at auth1.pl line 9. [or wherever] + +...because the C<$browser> doesn't know any the username and password +for that realm ("Unicode-MailList-Archives") at that host +("www.unicode.org"). The simplest way to let the browser know about this +is to use the C<credentials> method to let it know about a username and +password that it can try using for that realm at that host. The syntax is: + + $browser->credentials( + 'servername:portnumber', + 'realm-name', + 'username' => 'password' + ); + +In most cases, the port number is 80, the default TCP/IP port for HTTP; and +you usually call the C<credentials> method before you make any requests. +For example: + + $browser->credentials( + 'reports.mybazouki.com:80', + 'web_server_usage_reports', + 'plinky' => 'banjo123' + ); + +So if we add the following to the program above, right after the C<< +$browser = LWP::UserAgent->new; >> line... + + $browser->credentials( # add this to our $browser 's "key ring" + 'www.unicode.org:80', + 'Unicode-MailList-Archives', + 'unicode-ml' => 'unicode' + ); + +...then when we run it, the request succeeds, instead of causing the +C<die> to be called. + + + +=for comment + ########################################################################## + +=head2 Accessing HTTPS URLs + +When you access an HTTPS URL, it'll work for you just like an HTTP URL +would -- if your LWP installation has HTTPS support (via an appropriate +Secure Sockets Layer library). For example: + + use LWP; + my $url = 'https://www.paypal.com/'; # Yes, HTTPS! + my $browser = LWP::UserAgent->new; + my $response = $browser->get($url); + die "Error at $url\n ", $response->status_line, "\n Aborting" + unless $response->is_success; + print "Whee, it worked! I got that ", + $response->content_type, " document!\n"; + +If your LWP installation doesn't have HTTPS support set up, then the +response will be unsuccessful, and you'll get this error message: + + Error at https://www.paypal.com/ + 501 Protocol scheme 'https' is not supported + Aborting at paypal.pl line 7. [or whatever program and line] + +If your LWP installation I<does> have HTTPS support installed, then the +response should be successful, and you should be able to consult +C<$response> just like with any normal HTTP response. + +For information about installing HTTPS support for your LWP +installation, see the helpful F<README.SSL> file that comes in the +libwww-perl distribution. + + +=for comment + ########################################################################## + + + +=head2 Getting Large Documents + +When you're requesting a large (or at least potentially large) document, +a problem with the normal way of using the request methods (like C<< +$response = $browser->get($url) >>) is that the response object in +memory will have to hold the whole document -- I<in memory>. If the +response is a thirty megabyte file, this is likely to be quite an +imposition on this process's memory usage. + +A notable alternative is to have LWP save the content to a file on disk, +instead of saving it up in memory. This is the syntax to use: + + $response = $ua->get($url, + ':content_file' => $filespec, + ); + +For example, + + $response = $ua->get('http://search.cpan.org/', + ':content_file' => '/tmp/sco.html' + ); + +When you use this C<:content_file> option, the C<$response> will have +all the normal header lines, but C<< $response->content >> will be +empty. + +Note that this ":content_file" option isn't supported under older +versions of LWP, so you should consider adding C<use LWP 5.66;> to check +the LWP version, if you think your program might run on systems with +older versions. + +If you need to be compatible with older LWP versions, then use +this syntax, which does the same thing: + + use HTTP::Request::Common; + $response = $ua->request( GET($url), $filespec ); + + +=for comment + ########################################################################## + + +=head1 SEE ALSO + +Remember, this article is just the most rudimentary introduction to +LWP -- to learn more about LWP and LWP-related tasks, you really +must read from the following: + +=over + +=item * + +L<LWP::Simple> -- simple functions for getting/heading/mirroring URLs + +=item * + +L<LWP> -- overview of the libwww-perl modules + +=item * + +L<LWP::UserAgent> -- the class for objects that represent "virtual browsers" + +=item * + +L<HTTP::Response> -- the class for objects that represent the response to +a LWP response, as in C<< $response = $browser->get(...) >> + +=item * + +L<HTTP::Message> and L<HTTP::Headers> -- classes that provide more methods +to HTTP::Response. + +=item * + +L<URI> -- class for objects that represent absolute or relative URLs + +=item * + +L<URI::Escape> -- functions for URL-escaping and URL-unescaping strings +(like turning "this & that" to and from "this%20%26%20that"). + +=item * + +L<HTML::Entities> -- functions for HTML-escaping and HTML-unescaping strings +(like turning "C. & E. BrontE<euml>" to and from "C. & E. Brontë") + +=item * + +L<HTML::TokeParser> and L<HTML::TreeBuilder> -- classes for parsing HTML + +=item * + +L<HTML::LinkExtor> -- class for finding links in HTML documents + +=item * + +The book I<Perl & LWP> by Sean M. Burke. O'Reilly & Associates, +2002. ISBN: 0-596-00178-9, L<http://www.oreilly.com/catalog/perllwp/>. The +whole book is also available free online: +L<http://lwp.interglacial.com>. + +=back + + +=head1 COPYRIGHT + +Copyright 2002, Sean M. Burke. You can redistribute this document and/or +modify it, but only under the same terms as Perl itself. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=for comment + ########################################################################## + +=cut + +# End of Pod diff --git a/Master/tlpkg/tlperl/lib/perllocal.pod b/Master/tlpkg/tlperl/lib/perllocal.pod index feec6d0e2bf..26d7596868a 100644 --- a/Master/tlpkg/tlperl/lib/perllocal.pod +++ b/Master/tlpkg/tlperl/lib/perllocal.pod @@ -108,3 +108,135 @@ C<EXE_FILES: ptksh ptked gedi> =back +=head2 Sat Feb 12 11:49:20 2011: C<Module> L<File::Which|File::Which> + +=over 4 + +=item * + +C<installed into: x:\perlnew\site\lib> + +=item * + +C<LINKTYPE: dynamic> + +=item * + +C<VERSION: 1.09> + +=item * + +C<EXE_FILES: script/pwhich> + +=back + +=head2 Sat Feb 12 11:54:11 2011: C<Module> L<Digest::SHA1|Digest::SHA1> + +=over 4 + +=item * + +C<installed into: x:\perlnew\site\lib> + +=item * + +C<LINKTYPE: dynamic> + +=item * + +C<VERSION: 2.13> + +=item * + +C<EXE_FILES: > + +=back + +=head2 Sun Feb 27 17:51:24 2011: C<Module> L<HTML::Tagset|HTML::Tagset> + +=over 4 + +=item * + +C<installed into: x:\perlnew\site\lib> + +=item * + +C<LINKTYPE: dynamic> + +=item * + +C<VERSION: 3.20> + +=item * + +C<EXE_FILES: > + +=back + +=head2 Sun Feb 27 17:52:43 2011: C<Module> L<HTML::Parser|HTML::Parser> + +=over 4 + +=item * + +C<installed into: x:\perlnew\site\lib> + +=item * + +C<LINKTYPE: dynamic> + +=item * + +C<VERSION: 3.68> + +=item * + +C<EXE_FILES: > + +=back + +=head2 Sun Feb 27 17:57:12 2011: C<Module> L<URI|URI> + +=over 4 + +=item * + +C<installed into: x:\perlnew\site\lib> + +=item * + +C<LINKTYPE: dynamic> + +=item * + +C<VERSION: 1.58> + +=item * + +C<EXE_FILES: > + +=back + +=head2 Sun Feb 27 17:58:59 2011: C<Module> L<LWP|LWP> + +=over 4 + +=item * + +C<installed into: x:\perlnew\site\lib> + +=item * + +C<LINKTYPE: dynamic> + +=item * + +C<VERSION: 5.837> + +=item * + +C<EXE_FILES: bin/lwp-request bin/lwp-mirror bin/lwp-rget bin/lwp-download bin/lwp-dump> + +=back + |