summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm313
1 files changed, 0 insertions, 313 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm
deleted file mode 100644
index 1d656cf850..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm
+++ /dev/null
@@ -1,313 +0,0 @@
-package LWP::Protocol;
-
-use parent 'LWP::MemberMixin';
-
-our $VERSION = '6.61';
-
-use strict;
-use Carp ();
-use HTTP::Status ();
-use HTTP::Response ();
-use Try::Tiny qw(try catch);
-
-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 =~ tr/.+-/_/; # 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
- try {
- (my $class = $ic) =~ s{::}{/}g;
- $class .= '.pm' unless $class =~ /\.pm$/;
- require $class;
- }
- catch {
- my $error = $_;
- if ($error =~ /Can't locate/) {
- $ic = '';
- }
- else {
- die "$error\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)};
-
- # This can't be moved to Try::Tiny due to the closures within causing
- # leaks on any version of Perl prior to 5.18.
- # https://perl5.git.perl.org/perl.git/commitdiff/a0d2bbd5c
- my $error = do { #catch
- local $@;
- local $\; # protect the print below from surprises
- eval { # try
- 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;
- }
- }
- 1;
- };
- $@;
- };
-
- if ($error) {
- chomp($error);
- $response->push_header('X-Died' => $error);
- $response->push_header("Client-Aborted", "die");
- };
- delete $response->{handlers}{response_data};
- delete $response->{handlers} unless %{$response->{handlers}};
- 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__
-
-=pod
-
-=head1 NAME
-
-LWP::Protocol - Base class for LWP protocols
-
-=head1 SYNOPSIS
-
- package LWP::Protocol::foo;
- use parent qw(LWP::Protocol);
-
-=head1 DESCRIPTION
-
-This class is used as 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 initialized subclass
-appropriate for that access method. In other words, the
-L<LWP::Protocol/create> function calls the constructor for one of its
-subclasses.
-
-All derived C<LWP::Protocol> classes need to override the C<request()>
-method which is used to service a request. The overridden method can
-make use of the C<collect()> method to collect together chunks of data
-as it is received.
-
-=head1 METHODS
-
-The following methods and functions are provided:
-
-=head2 new
-
- my $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.
-
-=head2 create
-
- my $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.
-
-=head2 implementor
-
- my $class = LWP::Protocol::implementor($scheme, [$class])
-
-Get and/or set implementor class for a scheme. Returns C<''> if the
-specified scheme is not supported.
-
-=head2 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.
-
-=head2 collect
-
- my $res = $prot->collect(undef, $response, $collector); # stored in $response
- my $res = $prot->collect($filename, $response, $collector);
- my $res = $prot->collect(sub { ... }, $response, $collector);
-
-Collect the content of a request, and process it appropriately into a scalar,
-file, or by calling a callback. If the first parameter is undefined, then the
-content is stored within the C<$response>. If it's a simple scalar, then it's
-interpreted as a file name and the content is written to this file. If it's a
-code reference, 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 C<$collector> signals C<EOF> by returning a reference to an
-empty string.
-
-The return value is the L<HTTP::Response> object reference.
-
-B<Note:> We will only use the callback or file argument if
-C<< $response->is_success() >>. This avoids sending content data for
-redirects and authentication responses to the callback which would be
-confusing.
-
-=head2 collect_once
-
- $prot->collect_once($arg, $response, $content)
-
-Can be called when the whole response content is available as content. This
-will invoke L<LWP::Protocol/collect> with a collector callback that
-returns a reference to C<$content> the first time and an empty string the
-next.
-
-=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.
-
-=cut