diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP')
27 files changed, 7062 insertions, 0 deletions
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 |