diff options
author | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
commit | 12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch) | |
tree | 0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
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.pm | 313 |
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 |