App-rs
view release on metacpan or search on metacpan
oautoload => [@a]);
my $o;
for (@a) {
last if eval {
$o = $_->new->pretty->canonical;
};
}
sub jw { $o->encode(shift) }
sub jr { $o->decode(shift) }
}
sub xsh {
my $f = shift;
if (not ref $f) {
my $h = {};
$h->{"capture-stdout"} = 1 if $f & 1;
$h->{"feed-stdin"} = 1 if $f & 2;
$f = $h;
}
my ($h, $i, $pr, @st) = ({pid => []}, 0);
if ($f->{"feed-stdin"}) {
my ($fi, $pid) = shift;
pipe $pr, my $pw;
if (not $pid = fork) {
close $pr;
print $pw $fi;
exit;
} else {
push @{$h->{pid}}, $pid;
}
}
while ($i <= @_) {
my $l = $i == @_;
my $a = $_[$i] if not $l;
if ($l or $a eq "|") {
pipe my $r, my $w if not $l or $f->{"capture-stdout"};
# there's no need to fork when executing the last command and we're required
# to substitute current process.
my $pid = fork unless $l and $f->{substitute};
if (not $pid) {
# always true except possibly the first.
open STDIN, "<&", $pr if $pr;
# always true except possibly the last.
open STDOUT, ">&", $w if $w;
while (ref $st[-1]) {
my ($h, $f) = pop @st;
if (ref \$h->{from} eq "SCALAR") { open $f, $h->{mode}, $h->{from} or die $! }
else { $f = $h->{from} }
open $h->{to}, $h->{mode} . "&", $f;
}
exec @st;
} else {
$pr = $r;
push @{$h->{pid}}, $pid;
@st = ();
}
} else {
push @st, $a;
}
$i++;
}
if ($f->{asynchronous}) {
$h->{stdout} = $pr if $f->{"capture-stdout"};
if ($f->{compact}) { $h }
elsif ($f->{"capture-stdout"}) { $pr }
else { wantarray ? @{$h->{pid}} : $h->{pid}[-1] }
} else {
if ($f->{"capture-stdout"}) {
local $/ if not wantarray;
$h->{stdout} = [<$pr>];
}
$h->{status} = [];
push @{$h->{status}}, waitpid($_, 0) == -1 ? undef : $? for @{$h->{pid}};
# they're meaningless now as they don't exist anymore.
delete $h->{pid};
if ($f->{compact}) { $h }
elsif ($f->{"capture-stdout"}) { wantarray ? @{$h->{stdout}} : $h->{stdout}[0] }
else { wantarray ? @{$h->{status}} : not $h->{status}[-1] }
}
}
sub arg_parse {
my $h = {};
while (@ARGV) {
my $a = shift @ARGV;
if ($a !~ /^-/) { unshift @ARGV, $a; last }
elsif ($a =~ /^--?$/) { last }
elsif ($a =~ /^--(.*?)=(.*)$/) { hash_madd_key($h, $1, $2) }
elsif ($a =~ /^--?(.*)$/) { $h->{$1} = 1 }
}
$h;
}
sub hash_madd_key {
my ($h, $k, $v) = @_;
if (exists $h->{$k}) {
$h->{$k} = [$h->{$k}] if ref $h->{$k} ne 'ARRAY';
push @{$h->{$k}}, $v;
} else {
$h->{$k} = $v;
}
}
sub linker {
my $s = shift;
$s->{i386} ?
"$s->{prefix}/lib/ld-linux.so.2" : $s->{arm} ?
"$s->{prefix}/lib/ld-linux-armhf.so.3" :
"$s->{prefix}/lib/ld-linux-x86-64.so.2";
}
sub add {
my $h = shift;
while (@_) {
my ($k, $v) = splice @_, 0, 2;
$h->{$k} = $v;
}
}
sub slice {
my $h = shift;
map { $_ => $h->{$_} } @_;
}
sub wf {
local $_ = shift;
if (-e) { unlink or die "$!: unable to remove $_ for writing.\n" }
elsif (m|(.*/)|) { make_path($1) unless -d }
if ($o->{json}) { jr($c) }
elsif ($o->{plain}) { $c }
elsif ($o->{html}) { html_parse($c) }
elsif ($o->{save}) {
die $r->{b} unless $r->{'status-code'} == 200;
wf($o->{save}, $c);
}
}
sub http_req {
# socket pool.
state $pool = {};
my ($x, $f) = @_;
# host key to identify socket.
my $hk = $x->{protocol} . '://' . $x->{hv}{host};
if (not $pool->{$hk}) {
say "creating new pool socket $hk.";
if ($x->{protocol} eq 'https') { $pool->{$hk} = connect_tls($x->{hv}{host}, 443) }
else { $pool->{$hk} = connect_tcp($x->{hv}{host}, 80) }
}
send $pool->{$hk}, http_unparse($x), MSG_NOSIGNAL;
my $h = http_parse_new();
# avoid undefined warning when checking length of $h->{c}.
$h->{c} = '';
while (1) {
my $b;
eval {
local $SIG{ALRM} = sub { die };
alarm 12;
recv $pool->{$hk}, $b, 1048576, 0;
alarm 0;
};
if ($@ or not $b) {
if ($@) { say 'timeout.' }
else { say 'remote-close.' }
my $_h = http_parse_new();
if ($f->{range} and length($h->{c})) {
$_h->{c} = $h->{c};
push @{$x->{hf}}, 'Range' if not exists $x->{hv}{range};
$x->{hv}{range} = 'bytes=' . length($h->{c}) . '-';
}
$h = $_h;
if ($x->{protocol} eq 'https') { $pool->{$hk} = connect_tls($x->{hv}{host}, 443) }
else { $pool->{$hk} = connect_tcp($x->{hv}{host}, 80) }
send $pool->{$hk}, http_unparse($x), MSG_NOSIGNAL;
} else {
return $h if http_parse($h, $b);
}
}
}
sub connect_tcp {
my ($err, $a) = getaddrinfo(@_);
die "getaddrinfo: $err" if $err;
socket my $fh, $a->{family}, SOCK_STREAM, 0 or die $!;
connect $fh, $a->{addr} or die $!;
$fh;
}
sub connect_tls {
my ($host, $port) = @_;
my ($p, $q);
socketpair $p, $q, AF_UNIX, SOCK_STREAM, 0;
xsh({asynchronous => 1}, qw/socat -/, "OPENSSL:$host:$port",
{to => *STDIN,
from => $q,
mode => '<'}, {to => *STDOUT,
from => $q,
mode => '>'});
$p;
}
sub http_parse_new {
{st => 'reading-header',
# remaining length.
rl => 'line',
# header value.
hv => {},
# header field.
hf => [],
# first line.
fl => 1};
}
sub http_parse {
my ($h, $b) = @_;
$h->{b} .= $b;
my $i = 0;
while ($i < length($b)) {
if ($h->{rl} eq "line") {
pos($b) = $i;
if ($b =~ /\n/g) {
$h->{l} .= substr($b, $i, pos($b) - $i), $i = pos($b);
$h->{l} =~ s/\r?\n$//;
if ($h->{st} eq "reading-header") {
if ($h->{fl}) {
if ($h->{l}) {
if ($h->{l} =~ m|^HTTP\s*/\s*(\d)\s*\.\s*(\d)\s+(\d{3})\s+(.*)$|) {
@$h{qw/type major minor status-code reason-phrase/} = ("reply", $1, $2, $3, $4);
} elsif ($h->{l} =~ m|^(.*?)\s+(.*?)\s+HTTP\s*/\s*(\d)\s*\.\s*(\d)$|) {
@$h{qw/type method request-uri major minor/} = ("request", $1, $2, $3, $4);
} else {
}
$h->{fl} = 0;
}
# empty line before request/reply ignored.
} else {
if (not $h->{l}) {
if ($h->{type} eq "reply" and $h->{"status-code"} =~ /^(1\d{2}|204|304)$/) {
return $i;
} elsif (exists $h->{hv}{"transfer-encoding"} and $h->{hv}{"transfer-encoding"} !~ /^identity$/i) {
$h->{st} = "reading-chunk-size";
} elsif (exists $h->{hv}{"content-length"}) {
$h->{rl} = $h->{hv}{"content-length"}, $h->{st} = "reading-content";
# content-length could be 0.
return $i if not $h->{rl};
} elsif ($h->{type} eq "reply") {
$h->{rl} = "eof";
} else {
return $i;
}
} elsif ($h->{l} =~ /^\s/) {
my $k = lc $h->{hf}[$#{$h->{hf}}];
if (ref $h->{hv}{$k} eq "ARRAY") {
my $r = $h->{hv}{$k};
$r->[$#$r] .= $h->{l};
( run in 0.555 second using v1.01-cache-2.11-cpan-f56aa216473 )