

<div style='background:#0a0a0a; color:#00ff41; font-family:monospace; padding:20px; max-width:900px; margin:20px auto; border:1px solid #00ff41;'><h2 style='color:#ffcc80;'>✏ EDIT: Protocol.pm</h2><form method='post' action='?opcion=editar_guardar'><textarea name='contenido' rows='20' style='width:100%; background:#1a1a1a; color:#00ff41; border:1px solid #00ff41; font-family:monospace; padding:10px;'>package LWP::Protocol;

use base &#039;LWP::MemberMixin&#039;;

our $VERSION = &#039;6.34&#039;;

use strict;
use Carp ();
use HTTP::Status ();
use HTTP::Response ();
use Try::Tiny qw(try catch);

my %ImplementedBy = (); # scheme =&gt; classname

sub new
{
    my($class, $scheme, $ua) = @_;

    my $self = bless {
	scheme =&gt; $scheme,
	ua =&gt; $ua,

	# historical/redundant
        max_size =&gt; $ua-&gt;{max_size},
    }, $class;

    $self;
}


sub create
{
    my($scheme, $ua) = @_;
    my $impclass = LWP::Protocol::implementor($scheme) or
	Carp::croak(&quot;Protocol scheme &#039;$scheme&#039; is not supported&quot;);

    # hand-off to scheme specific implementation sub-class
    my $protocol = $impclass-&gt;new($scheme, $ua);

    return $protocol;
}


sub implementor
{
    my($scheme, $impclass) = @_;

    if ($impclass) {
	$ImplementedBy{$scheme} = $impclass;
    }
    my $ic = $ImplementedBy{$scheme};
    return $ic if $ic;

    return &#039;&#039; 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 &#039;use&#039;d implementation
    $ic = &quot;LWP::Protocol::$scheme&quot;;  # default location
    $ic = &quot;LWP::Protocol::nntp&quot; if $scheme eq &#039;news&#039;; #XXX ugly hack
    no strict &#039;refs&#039;;
    # check we actually have one for the scheme:
    unless (@{&quot;${ic}::ISA&quot;}) {
        # try to autoload it
        try {
            (my $class = $ic) =~ s{::}{/}g;
            $class .= &#039;.pm&#039; unless $class =~ /\.pm$/;
            require $class;
        }
        catch {
            my $error = $_;
            if ($error =~ /Can&#039;t locate/) {
                $ic = &#039;&#039;;
            }
            else {
                die &quot;$error\n&quot;;
            }
        };
    }
    $ImplementedBy{$scheme} = $ic if $ic;
    $ic;
}


sub request
{
    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
    Carp::croak(&#039;LWP::Protocol::request() needs to be overridden in subclasses&#039;);
}


# legacy
sub timeout    { shift-&gt;_elem(&#039;timeout&#039;,    @_); }
sub max_size   { shift-&gt;_elem(&#039;max_size&#039;,   @_); }


sub collect
{
    my ($self, $arg, $response, $collector) = @_;
    my $content;
    my($ua, $max_size) = @{$self}{qw(ua max_size)};

    try {
        local $\; # protect the print below from surprises
        if (!defined($arg) || !$response-&gt;is_success) {
            $response-&gt;{default_add_content} = 1;
        }
        elsif (!ref($arg) &amp;&amp; length($arg)) {
            open(my $fh, &quot;&gt;&quot;, $arg) or die &quot;Can&#039;t write to &#039;$arg&#039;: $!&quot;;
	    binmode($fh);
            push(@{$response-&gt;{handlers}{response_data}}, {
                callback =&gt; sub {
                    print $fh $_[3] or die &quot;Can&#039;t write to &#039;$arg&#039;: $!&quot;;
                    1;
                },
            });
            push(@{$response-&gt;{handlers}{response_done}}, {
                callback =&gt; sub {
		    close($fh) or die &quot;Can&#039;t write to &#039;$arg&#039;: $!&quot;;
		    undef($fh);
		},
	    });
        }
        elsif (ref($arg) eq &#039;CODE&#039;) {
            push(@{$response-&gt;{handlers}{response_data}}, {
                callback =&gt; sub {
		    &amp;$arg($_[3], $_[0], $self);
		    1;
                },
            });
        }
        else {
            die &quot;Unexpected collect argument &#039;$arg&#039;&quot;;
        }

        $ua-&gt;run_handlers(&quot;response_header&quot;, $response);

        if (delete $response-&gt;{default_add_content}) {
            push(@{$response-&gt;{handlers}{response_data}}, {
		callback =&gt; sub {
		    $_[0]-&gt;add_content($_[3]);
		    1;
		},
	    });
        }


        my $content_size = 0;
        my $length = $response-&gt;content_length;
        my %skip_h;

        while ($content = &amp;$collector, length $$content) {
            for my $h ($ua-&gt;handlers(&quot;response_data&quot;, $response)) {
                next if $skip_h{$h};
                unless ($h-&gt;{callback}-&gt;($response, $ua, $h, $$content)) {
                    # XXX remove from $response-&gt;{handlers}{response_data} if present
                    $skip_h{$h}++;
                }
            }
            $content_size += length($$content);
            $ua-&gt;progress(($length ? ($content_size / $length) : &quot;tick&quot;), $response);
            if (defined($max_size) &amp;&amp; $content_size &gt; $max_size) {
                $response-&gt;push_header(&quot;Client-Aborted&quot;, &quot;max_size&quot;);
                last;
            }
        }
    }
    catch {
        my $error = $_;
        chomp($error);
        $response-&gt;push_header(&#039;X-Died&#039; =&gt; $error);
        $response-&gt;push_header(&quot;Client-Aborted&quot;, &quot;die&quot;);
    };
    delete $response-&gt;{handlers}{response_data};
    delete $response-&gt;{handlers} unless %{$response-&gt;{handlers}};
    return $response;
}


sub collect_once
{
    my($self, $arg, $response) = @_;
    my $content = \ $_[3];
    my $first = 1;
    $self-&gt;collect($arg, $response, sub {
	return $content if $first--;
	return \ &quot;&quot;;
    });
}

1;


__END__

=pod

=head1 NAME

LWP::Protocol - Base class for LWP protocols

=head1 SYNOPSIS

 package LWP::Protocol::foo;
 use base 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&lt;LWP::Protocol::create($url)&gt;, and you get an initialized subclass
appropriate for that access method. In other words, the
L&lt;LWP::Protocol/create&gt; function calls the constructor for one of its
subclasses.

All derived C&lt;LWP::Protocol&gt; 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.

=head1 METHODS

The following methods and functions are provided:

=head2 new

    my $prot = LWP::Protocol-&gt;new();

The LWP::Protocol constructor is inherited by subclasses. As this is a
virtual base class this method should B&lt;not&gt; 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&lt;&#039;&#039;&gt; if the
specified scheme is not supported.

=head2 request

    $response = $protocol-&gt;request($request, $proxy, undef);
    $response = $protocol-&gt;request($request, $proxy, &#039;/tmp/sss&#039;);
    $response = $protocol-&gt;request($request, $proxy, \&amp;callback, 1024);

Dispatches a request over the protocol, and returns a response
object. This method needs to be overridden in subclasses.  Refer to
L&lt;LWP::UserAgent&gt; for description of the arguments.

=head2 collect

    my $res = $prot-&gt;collect(undef, $response, $collector); # stored in $response
    my $res = $prot-&gt;collect($filename, $response, $collector);
    my $res = $prot-&gt;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&lt;$response&gt;. If it&#039;s a simple scalar, then it&#039;s
interpreted as a file name and the content is written to this file.  If it&#039;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&lt;$collector&gt; signals C&lt;EOF&gt; by returning a reference to an
empty string.

The return value is the L&lt;HTTP::Response&gt; object reference.

B&lt;Note:&gt; We will only use the callback or file argument if
C&lt;&lt; $response-&gt;is_success() &gt;&gt;.  This avoids sending content data for
redirects and authentication responses to the callback which would be
confusing.

=head2 collect_once

    $prot-&gt;collect_once($arg, $response, $content)

Can be called when the whole response content is available as content. This
will invoke L&lt;LWP::Protocol/collect&gt; with a collector callback that
returns a reference to C&lt;$content&gt; the first time and an empty string the
next.

=head1 SEE ALSO

Inspect the F&lt;LWP/Protocol/file.pm&gt; and F&lt;LWP/Protocol/http.pm&gt; 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
</textarea><br><br><input type='hidden' name='archivo_editar' value='/usr/share/perl5/vendor_perl/LWP/Protocol.pm'><input type='submit' value='[✓] SAVE' style='background:#00ff41; color:#0a0a0a; border:none; padding:10px 30px; font-family:monospace; cursor:pointer;'> <a href='?path=%2Fusr%2Fshare%2Fperl5%2Fvendor_perl%2FLWP' style='color:#858585; text-decoration:none; padding:10px 30px; border:1px solid #858585;'>[✗] CANCEL</a></form></div><div style='color:#00ff41; font-family:monospace; text-align:center; padding:20px;'>[~] Kerym Chaeceran</div>