view release on metacpan or  search on metacpan

lib/AnyEvent/HTTP/LWP/UserAgent.pm  view on Meta::CPAN

package AnyEvent::HTTP::LWP::UserAgent;
{
  $AnyEvent::HTTP::LWP::UserAgent::VERSION = '0.10';
}

use strict;
use warnings;

#ABSTRACT: LWP::UserAgent interface but works using AnyEvent::HTTP


use parent qw(LWP::UserAgent);

use AnyEvent 5;           # AE syntax
use AnyEvent::HTTP 2.1;   # http(s)/1.1
use HTTP::Response;
use LWP::UserAgent 5.815; # first version with handlers


sub conn_cache {
    my $self = shift;

    my $res = $self->SUPER::conn_cache(@_);
    my $cache = $self->SUPER::conn_cache;
    if ($cache) {
        my $total_capacity = $cache->total_capacity;
        $total_capacity = 100_000 unless(defined($total_capacity));
        $AnyEvent::HTTP::ACTIVE = $total_capacity;
    }

    return $res;
}


sub simple_request_async {
    my ($self, $in_req, $arg, $size) = @_;

    my ($method, $uri_ref, $args) = $self->lwp_request2anyevent_request($in_req);

    my $cv = AE::cv;
    my $out_req;
    my $content = '';
    my $fh;
    if(!ref($arg) && defined($arg) && length($arg)) {
        open $fh, '>', $arg or $cv->croak("Can't write to '$arg': $!");
        binmode $fh;
        $args->{on_body} = sub {
            my ($d, $h) = @_;
            if($out_req->code < 200 || 300 <= $out_req->code) { # not success
                $content .= $d;
            } else {
                print $fh $d or $cv->croak("Can't write to '$arg': $!");
            }
            return 1;
        };
    } elsif(ref($arg) eq 'CODE') {
        $args->{on_body} = sub {
            my ($d, $h) = @_;
            if($out_req->code < 200 || 300 <= $out_req->code) { # not success
                $content .= $d;
            } else {
                eval { $arg->($d, $out_req, undef) };
                my $err = $@;
                if($err) {
                    chomp $err;
                    $out_req->header('X-Died' => $err);
                    $out_req->header('Client-Aborted' => 'die');
                    return 0;
                }
            }
            return 1;
        };
    }
    my $header_init = sub {
        my ($d, $h) = @_;

        # special AnyEvent::HTTP's headers
        my $code = delete $h->{Status};
        my $message = delete $h->{Reason};

        # Now we don't use in any place this AnyEvent::HTTP pseudo-headers, so
        # just delete it
        for (qw/HTTPVersion OrigStatus OrigReason Redirect URL/) {
            delete $h->{$_};
        }

        # AnyEvent::HTTP join headers by comma
        # in this header exists many times in response.
        # It is some trie to split such headers, I need
        # to read RFCs more carefully.
        my $headers = HTTP::Headers->new;
        while (my ($header, $value) = each %$h) {
            # In previous versions it was a place where heavily used
            # Coro stack (if Coro used) when you had pseudo-header URL
            # and URL was really big.
            # Now it's not such a big problem, we delete URL pseudo-header
            # and haven't sudden gigantous headers (I hope).
            my @v = $value =~ /^([^ ].*?[^ ],)*([^ ].*?[^ ])$/;
            @v = grep { defined($_) } @v;
            if (scalar(@v) > 1) {
                @v = map { s/,$//; $_ } @v;
                $value = \@v;
            }
            $headers->header($header => $value);
        }