"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/lib/LWP/Protocol.pm" (26 Nov 2019, 9015 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Protocol.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 6.42_vs_6.43.

    1 package LWP::Protocol;
    2 
    3 use base 'LWP::MemberMixin';
    4 
    5 our $VERSION = '6.43';
    6 
    7 use strict;
    8 use Carp ();
    9 use HTTP::Status ();
   10 use HTTP::Response ();
   11 use Try::Tiny qw(try catch);
   12 
   13 my %ImplementedBy = (); # scheme => classname
   14 
   15 sub new
   16 {
   17     my($class, $scheme, $ua) = @_;
   18 
   19     my $self = bless {
   20     scheme => $scheme,
   21     ua => $ua,
   22 
   23     # historical/redundant
   24         max_size => $ua->{max_size},
   25     }, $class;
   26 
   27     $self;
   28 }
   29 
   30 
   31 sub create
   32 {
   33     my($scheme, $ua) = @_;
   34     my $impclass = LWP::Protocol::implementor($scheme) or
   35     Carp::croak("Protocol scheme '$scheme' is not supported");
   36 
   37     # hand-off to scheme specific implementation sub-class
   38     my $protocol = $impclass->new($scheme, $ua);
   39 
   40     return $protocol;
   41 }
   42 
   43 
   44 sub implementor
   45 {
   46     my($scheme, $impclass) = @_;
   47 
   48     if ($impclass) {
   49     $ImplementedBy{$scheme} = $impclass;
   50     }
   51     my $ic = $ImplementedBy{$scheme};
   52     return $ic if $ic;
   53 
   54     return '' unless $scheme =~ /^([.+\-\w]+)$/;  # check valid URL schemes
   55     $scheme = $1; # untaint
   56     $scheme =~ tr/.+-/_/;  # make it a legal module name
   57 
   58     # scheme not yet known, look for a 'use'd implementation
   59     $ic = "LWP::Protocol::$scheme";  # default location
   60     $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
   61     no strict 'refs';
   62     # check we actually have one for the scheme:
   63     unless (@{"${ic}::ISA"}) {
   64         # try to autoload it
   65         try {
   66             (my $class = $ic) =~ s{::}{/}g;
   67             $class .= '.pm' unless $class =~ /\.pm$/;
   68             require $class;
   69         }
   70         catch {
   71             my $error = $_;
   72             if ($error =~ /Can't locate/) {
   73                 $ic = '';
   74             }
   75             else {
   76                 die "$error\n";
   77             }
   78         };
   79     }
   80     $ImplementedBy{$scheme} = $ic if $ic;
   81     $ic;
   82 }
   83 
   84 
   85 sub request
   86 {
   87     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
   88     Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
   89 }
   90 
   91 
   92 # legacy
   93 sub timeout    { shift->_elem('timeout',    @_); }
   94 sub max_size   { shift->_elem('max_size',   @_); }
   95 
   96 
   97 sub collect
   98 {
   99     my ($self, $arg, $response, $collector) = @_;
  100     my $content;
  101     my($ua, $max_size) = @{$self}{qw(ua max_size)};
  102 
  103     # This can't be moved to Try::Tiny due to the closures within causing
  104     # leaks on any version of Perl prior to 5.18.
  105     # https://perl5.git.perl.org/perl.git/commitdiff/a0d2bbd5c
  106     my $error = do { #catch
  107         local $@;
  108         local $\; # protect the print below from surprises
  109         eval { # try
  110             if (!defined($arg) || !$response->is_success) {
  111                 $response->{default_add_content} = 1;
  112             }
  113             elsif (!ref($arg) && length($arg)) {
  114                 open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
  115                 binmode($fh);
  116                 push(@{$response->{handlers}{response_data}}, {
  117                     callback => sub {
  118                         print $fh $_[3] or die "Can't write to '$arg': $!";
  119                         1;
  120                     },
  121                 });
  122                 push(@{$response->{handlers}{response_done}}, {
  123                     callback => sub {
  124                         close($fh) or die "Can't write to '$arg': $!";
  125                         undef($fh);
  126                     },
  127                 });
  128             }
  129             elsif (ref($arg) eq 'CODE') {
  130                 push(@{$response->{handlers}{response_data}}, {
  131                     callback => sub {
  132                         &$arg($_[3], $_[0], $self);
  133                         1;
  134                     },
  135                 });
  136             }
  137             else {
  138                 die "Unexpected collect argument '$arg'";
  139             }
  140 
  141             $ua->run_handlers("response_header", $response);
  142 
  143             if (delete $response->{default_add_content}) {
  144                 push(@{$response->{handlers}{response_data}}, {
  145                     callback => sub {
  146                         $_[0]->add_content($_[3]);
  147                         1;
  148                     },
  149                 });
  150             }
  151 
  152 
  153             my $content_size = 0;
  154             my $length = $response->content_length;
  155             my %skip_h;
  156 
  157             while ($content = &$collector, length $$content) {
  158                 for my $h ($ua->handlers("response_data", $response)) {
  159                     next if $skip_h{$h};
  160                     unless ($h->{callback}->($response, $ua, $h, $$content)) {
  161                         # XXX remove from $response->{handlers}{response_data} if present
  162                         $skip_h{$h}++;
  163                     }
  164                 }
  165                 $content_size += length($$content);
  166                 $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
  167                 if (defined($max_size) && $content_size > $max_size) {
  168                     $response->push_header("Client-Aborted", "max_size");
  169                     last;
  170                 }
  171             }
  172             1;
  173         };
  174         $@;
  175     };
  176 
  177     if ($error) {
  178         chomp($error);
  179         $response->push_header('X-Died' => $error);
  180         $response->push_header("Client-Aborted", "die");
  181     };
  182     delete $response->{handlers}{response_data};
  183     delete $response->{handlers} unless %{$response->{handlers}};
  184     return $response;
  185 }
  186 
  187 
  188 sub collect_once
  189 {
  190     my($self, $arg, $response) = @_;
  191     my $content = \ $_[3];
  192     my $first = 1;
  193     $self->collect($arg, $response, sub {
  194     return $content if $first--;
  195     return \ "";
  196     });
  197 }
  198 
  199 1;
  200 
  201 
  202 __END__
  203 
  204 =pod
  205 
  206 =head1 NAME
  207 
  208 LWP::Protocol - Base class for LWP protocols
  209 
  210 =head1 SYNOPSIS
  211 
  212  package LWP::Protocol::foo;
  213  use base qw(LWP::Protocol);
  214 
  215 =head1 DESCRIPTION
  216 
  217 This class is used as the base class for all protocol implementations
  218 supported by the LWP library.
  219 
  220 When creating an instance of this class using
  221 C<LWP::Protocol::create($url)>, and you get an initialized subclass
  222 appropriate for that access method. In other words, the
  223 L<LWP::Protocol/create> function calls the constructor for one of its
  224 subclasses.
  225 
  226 All derived C<LWP::Protocol> classes need to override the request()
  227 method which is used to service a request. The overridden method can
  228 make use of the collect() function to collect together chunks of data
  229 as it is received.
  230 
  231 =head1 METHODS
  232 
  233 The following methods and functions are provided:
  234 
  235 =head2 new
  236 
  237     my $prot = LWP::Protocol->new();
  238 
  239 The LWP::Protocol constructor is inherited by subclasses. As this is a
  240 virtual base class this method should B<not> be called directly.
  241 
  242 =head2 create
  243 
  244     my $prot = LWP::Protocol::create($scheme)
  245 
  246 Create an object of the class implementing the protocol to handle the
  247 given scheme. This is a function, not a method. It is more an object
  248 factory than a constructor. This is the function user agents should
  249 use to access protocols.
  250 
  251 =head2 implementor
  252 
  253     my $class = LWP::Protocol::implementor($scheme, [$class])
  254 
  255 Get and/or set implementor class for a scheme.  Returns C<''> if the
  256 specified scheme is not supported.
  257 
  258 =head2 request
  259 
  260     $response = $protocol->request($request, $proxy, undef);
  261     $response = $protocol->request($request, $proxy, '/tmp/sss');
  262     $response = $protocol->request($request, $proxy, \&callback, 1024);
  263 
  264 Dispatches a request over the protocol, and returns a response
  265 object. This method needs to be overridden in subclasses.  Refer to
  266 L<LWP::UserAgent> for description of the arguments.
  267 
  268 =head2 collect
  269 
  270     my $res = $prot->collect(undef, $response, $collector); # stored in $response
  271     my $res = $prot->collect($filename, $response, $collector);
  272     my $res = $prot->collect(sub { ... }, $response, $collector);
  273 
  274 Collect the content of a request, and process it appropriately into a scalar,
  275 file, or by calling a callback. If the first parameter is undefined, then the
  276 content is stored within the C<$response>. If it's a simple scalar, then it's
  277 interpreted as a file name and the content is written to this file.  If it's a
  278 code reference, then content is passed to this routine.
  279 
  280 The collector is a routine that will be called and which is
  281 responsible for returning pieces (as ref to scalar) of the content to
  282 process.  The C<$collector> signals C<EOF> by returning a reference to an
  283 empty string.
  284 
  285 The return value is the L<HTTP::Response> object reference.
  286 
  287 B<Note:> We will only use the callback or file argument if
  288 C<< $response->is_success() >>.  This avoids sending content data for
  289 redirects and authentication responses to the callback which would be
  290 confusing.
  291 
  292 =head2 collect_once
  293 
  294     $prot->collect_once($arg, $response, $content)
  295 
  296 Can be called when the whole response content is available as content. This
  297 will invoke L<LWP::Protocol/collect> with a collector callback that
  298 returns a reference to C<$content> the first time and an empty string the
  299 next.
  300 
  301 =head1 SEE ALSO
  302 
  303 Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
  304 for examples of usage.
  305 
  306 =head1 COPYRIGHT
  307 
  308 Copyright 1995-2001 Gisle Aas.
  309 
  310 This library is free software; you can redistribute it and/or
  311 modify it under the same terms as Perl itself.
  312 
  313 =cut