File Coverage

lib/LWP/CurlLog.pm

Criterion	Covered	Total	%
statement	76	104	73.0
branch	13	26	50.0
condition	3	12	25.0
subroutine	10	11	90.9
pod	0	3	0.0
total	102	156	65.3

package LWP::CurlLog;
use strict;
use warnings;

BEGIN {
    eval {
        require LWP::UserAgent;
    };
    eval {
        require HTTP::Tiny;
    };
}

our $VERSION = "0.04";
our %opts = (
    file => undef,
    response => 1,
    options => "-k",
    timing => 0,
    trace => 0,
);

sub import {
    my ($package, %args) = @_;
    for my $key (keys %args) {
        $opts{$key} = $args{$key};
    }

    if (!$opts{file}) {
        $opts{fh} = \*STDERR;
    }
    else {
        my $expanded_file = $opts{file};
        if ($expanded_file =~ m{^~/}) {
            my $home = $ENV{HOME} || (getpwuid($<))[7];
            $expanded_file =~ s{^~/}{$home/};
        }
        open $opts{fh}, ">>", $expanded_file or die "Can't open $opts{file}: $!";
    }
    select($opts{fh});
    $| = 1;
    select(STDOUT);
}

no strict "refs";
no warnings "redefine";

my $orig_lusr = \&LWP::UserAgent::send_request;
*{"LWP::UserAgent::send_request"} = sub {
    my ($self, $req) = @_;
    my $headers = {};
    for my $name ($req->headers()->header_field_names()) {
        $headers->{$name} = $req->{headers}{$name};
    }
    my $content = $req->decoded_content();
    my $res = request("LWP", $orig_lusr, \@_, $req->method(), $req->uri(), $headers, $content);
    return $res;
};

my $orig_htr = \&HTTP::Tiny::_request;
*{"HTTP::Tiny::_request"} = sub {
    my ($self, $method, $url, $args) = @_;
    my $res = request("HT", $orig_htr, \@_, $method, $url, $args->{headers}, $args->{content});
    return $res;
};

sub request {
    my ($module, $orig_sub, $orig_args, $method, $url, $headers, $content) = @_;

    my $cmd = "curl ";
    if ($url =~ /[=&;?]/) {
        $cmd .= "\"$url\" ";
    }
    else {
        $cmd .= "$url ";
    }
    if ($opts{options}) {
        $cmd .= "$opts{options} ";
    }

    if ($method && ($method ne "GET" || length $content)) {
        $cmd .= "-X $method ";
    }

    for my $name (keys %$headers) {
        if ($name =~ /^(Content-Length|User-Agent)$/i) {
            next;
        }
        my $value = $headers->{$name};
        $value =~ s{([\\\$"])}{\\$1}g;
        $cmd .= "-H \"$name: $value\" ";
    }

    if (defined $content && length $content) {
        $content =~ s{([\\\$"])}{\\$1}g;
        $cmd .= "-d \"$content\" ";
    }
    $cmd =~ s/\s*$//;

    log_print("# " . localtime() . " $module request\n");
    log_print_stack();
    log_print("$cmd\n");
    my $time1 = time();
    my $res = $orig_sub->(@$orig_args);
    my $time2 = time();

    if ($opts{response}) {
        log_print("\n# " . localtime() . " $module response\n");
        my $str;
        if (eval {$res->isa("HTTP::Response")}) {
            $str = $res->as_string();
        }
        else {
            $str = "$res->{protocol} $res->{status} $res->{reason}\n";
            for my $name (keys %{$res->{headers}}) {
                $str .= "$name: $res->{headers}{$name}\n";
            }
            $str .= "\n";
            $str .= $res->{content};
        }
        $str =~ s/\s*$//g;
        log_print("$str\n");
    }
    if ($opts{timing}) {
        my $diff = $time2 - $time1;
        log_print("# ${diff}s\n");
    }

    log_print("\n");

    return $res;
}

sub log_print {
    my (@args) = @_;
    my $mesg = join("", @args);
    print {$opts{fh}} $mesg;
}


sub log_print_stack {
    my @callers;
    for (my $i = 0; my @caller = caller($i); $i++) {
        push @callers, \@caller;
    }

    my @filtered_callers;
    CALLER: for my $caller (reverse @callers) {
        my ($package, $file, $line, $long_name) = @$caller;
        for my $test_package ("LWP::CurlLog", "HTTP::Tiny", "HTTP::AnyUA", "LWP::UserAgent") {
            if ($package =~ /^${test_package}($|::)/) {
                last CALLER;
            }
        }
        push @filtered_callers, $caller;

    }
    if (!$opts{trace}) {
        @filtered_callers = ($filtered_callers[-1]);
    }

    for my $caller (@filtered_callers) {
        my ($package, $file, $line, $long_name) = @$caller;
        my $name = $long_name;
        $name =~ s/.*:://;
        log_print("#     $name $file $line\n");
    }
}

1;

__END__