-
Notifications
You must be signed in to change notification settings - Fork 215
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge branch 'feature/http-module' into develop
- Loading branch information
Showing
6 changed files
with
148 additions
and
134 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_user_agent_command 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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,23 +1,26 @@ | ||
| #!/usr/bin/env perl | ||
| use strict; | ||
| use warnings; | ||
|
|
||
| use FindBin; | ||
| use lib $FindBin::Bin; | ||
| use App::perlbrew; | ||
| require 'test_helpers.pl'; | ||
|
|
||
| use App::Perlbrew::HTTP qw(http_user_agent_program); | ||
|
|
||
| use Test::More; | ||
| use Test::Exception; | ||
|
|
||
| for my $prog (qw(curl wget fetch)) { | ||
| $App::perlbrew::HTTP_USER_AGENT_PROGRAM = $prog; | ||
| is App::perlbrew::http_user_agent_program(), $prog, "UA Program can be set to: $prog"; | ||
| subtest "UA set to $prog", sub { | ||
| local $App::Perlbrew::HTTP::HTTP_USER_AGENT_PROGRAM = $prog; | ||
| is http_user_agent_program(), $prog, "UA Program can be set to: $prog"; | ||
| }; | ||
| } | ||
|
|
||
| $App::perlbrew::HTTP_USER_AGENT_PROGRAM = "something-that-is-not-recognized"; | ||
| dies_ok { | ||
| App::perlbrew::http_user_agent_program(); | ||
| } "should die when asked to use unrecognized http UA program"; | ||
| subtest "something not supported", sub { | ||
| local $App::Perlbrew::HTTP::HTTP_USER_AGENT_PROGRAM = "something-that-is-not-recognized"; | ||
| dies_ok { | ||
| http_user_agent_program(); | ||
| } "should die when asked to use unrecognized http UA program"; | ||
| }; | ||
|
|
||
| done_testing; |
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