diff --git a/lib/App/Perlbrew/HTTP.pm b/lib/App/Perlbrew/HTTP.pm new file mode 100644 index 00000000..a59b7e9d --- /dev/null +++ b/lib/App/Perlbrew/HTTP.pm @@ -0,0 +1,123 @@ +package App::Perlbrew::HTTP; +use strict; +use warnings; +use 5.008; + +use Exporter 'import'; +our @EXPORT_OK = qw(http_user_agent_program http_get http_download); + +our $HTTP_USER_AGENT_PROGRAM; + +my %commands = ( + curl => { + test => '--version >/dev/null 2>&1', + get => '--silent --location --fail -o - {url}', + download => '--silent --location --fail -o {output} {url}', + order => 1, + + # Exit code is 22 on 404s etc + die_on_error => sub { die 'Page not retrieved; HTTP error code 400 or above.' if ($_[ 0 ] >> 8 == 22); }, + }, + wget => { + test => '--version >/dev/null 2>&1', + get => '--quiet -O - {url}', + download => '--quiet -O {output} {url}', + order => 2, + + # Exit code is not 0 on error + die_on_error => sub { die 'Page not retrieved: fetch failed.' if ($_[ 0 ]); }, + }, + fetch => { + test => '--version >/dev/null 2>&1', + get => '-o - {url}', + download => '-o {output} {url}', + order => 3, + + # Exit code is 8 on 404s etc + die_on_error => sub { die 'Server issued an error response.' if ($_[ 0 ] >> 8 == 8); }, + } +); + +sub http_user_agent_program { + $HTTP_USER_AGENT_PROGRAM ||= do { + my $program; + + for my $p (sort {$commands{$a}{order}<=>$commands{$b}{order}} keys %commands) { + my $code = system("$p $commands{$p}->{test}") >> 8; + if ($code != 127) { + $program = $p; + last; + } + } + + unless ($program) { + die "[ERROR] Cannot find a proper http user agent program. Please install curl or wget.\n"; + } + + $program; + }; + + die "[ERROR] Unrecognized http user agent program: $HTTP_USER_AGENT_PROGRAM. It can only be one of: ".join(",", keys %commands)."\n" unless $commands{$HTTP_USER_AGENT_PROGRAM}; + + return $HTTP_USER_AGENT_PROGRAM; +} + +sub http_user_agent_command { + my ($purpose, $params) = @_; + my $ua = http_user_agent_program; + my $cmd = $ua . " " . $commands{ $ua }->{ $purpose }; + for (keys %$params) { + $cmd =~ s!{$_}!$params->{$_}!g; + } + return ($ua, $cmd) if wantarray; + return $cmd; +} + +sub http_download { + my ($url, $path) = @_; + + if (-e $path) { + die "ERROR: The download target < $path > already exists.\n"; + } + + my $partial = 0; + local $SIG{TERM} = local $SIG{INT} = sub { $partial++ }; + + my $download_command = http_user_agent_command(download => { url => $url, output => $path }); + + my $status = system($download_command); + if ($partial) { + $path->unlink; + return "ERROR: Interrupted."; + } + unless ($status == 0) { + $path->unlink; + return "ERROR: Failed to execute the command\n\n\t$download_command\n\nReason:\n\n\t$?"; + } + return 0; +} + +sub http_get { + my ($url, $header, $cb) = @_; + + if (ref($header) eq 'CODE') { + $cb = $header; + $header = undef; + } + + my ($program, $command) = http_user_agent_command(get => { url => $url }); + + open my $fh, '-|', $command + or die "open() pipe for '$command': $!"; + + local $/; + my $body = <$fh>; + close $fh; + + # check if the download has failed and die automatically + $commands{ $program }{ die_on_error }->($?); + + return $cb ? $cb->($body) : $body; +} + +1; diff --git a/t/http-ua-detect-non-curl.t b/t/http-ua-detect-non-curl.t index 280c016a..a8f5daef 100644 --- a/t/http-ua-detect-non-curl.t +++ b/t/http-ua-detect-non-curl.t @@ -8,7 +8,8 @@ BEGIN { } use File::Which qw(which); -use App::perlbrew; +use App::Perlbrew::HTTP qw(http_user_agent_program); + use Test::More; chmod 0755, "$Bin/fake-bin/curl"; @@ -28,7 +29,7 @@ elsif (which("fetch")) { } if ($expected_ua) { - my $detected_ua = App::perlbrew::http_user_agent_program(); + my $detected_ua = http_user_agent_program(); is $detected_ua, $expected_ua, "UA: $detected_ua"; } else { pass("Neither wget nor fetch can be found. This test requers at least one of them to be there."); diff --git a/t/http-ua-detect.t b/t/http-ua-detect.t index 69726c6e..6021dc75 100644 --- a/t/http-ua-detect.t +++ b/t/http-ua-detect.t @@ -2,7 +2,7 @@ use strict; use warnings; use File::Which qw(which); -use App::perlbrew; +use App::Perlbrew::HTTP qw(http_user_agent_program); use Test::More; my $expected_ua; @@ -16,7 +16,7 @@ elsif (which("fetch")) { $expected_ua = "fetch"; } -my $detected_ua = App::perlbrew::http_user_agent_program(); +my $detected_ua = http_user_agent_program(); is $detected_ua, $expected_ua, "UA: $detected_ua"; done_testing; diff --git a/t/http.t b/t/http.t index aea8b37b..4010c6c9 100644 --- a/t/http.t +++ b/t/http.t @@ -5,6 +5,8 @@ use App::perlbrew; use File::Temp 'tempdir'; use IO::All; +use App::Perlbrew::HTTP qw(http_user_agent_program http_get http_download); + unless ($ENV{PERLBREW_DEV_TEST}) { plan skip_all => < sub { +describe "http_get function" => sub { my ($output); before all => sub { - App::perlbrew::http_get( + http_get( "https://get.perlbrew.pl", undef, sub { $output = $_[0]; } @@ -38,7 +40,7 @@ describe "App::perlbrew::http_get function" => sub { }; }; -describe "App::perlbrew::http_download function, downloading the perlbrew-installer." => sub { +describe "http_download function, downloading the perlbrew-installer." => sub { my ($dir, $output, $download_error); before all => sub { @@ -55,7 +57,7 @@ Therefore we cannot proceed the test. REASON } - my $download_error = App::perlbrew::http_download("https://install.perlbrew.pl", $output); + my $download_error = http_download("https://install.perlbrew.pl", $output); }; it "downloads to the wanted path" => sub { @@ -68,4 +70,3 @@ REASON }; runtests unless caller; -