-
Notifications
You must be signed in to change notification settings - Fork 216
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
gather the http_* subroutines in perlbrew.pm as a module.
- Loading branch information
Showing
4 changed files
with
135 additions
and
10 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters