view release on metacpan or  search on metacpan

rs.pm  view on Meta::CPAN

		# 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 }
	open my $fh, '>', $_ or die "open $_ for writing: $!";
	if (@_)	{ syswrite $fh, shift }
	else	{ $fh }
}
sub purl {
	my $o = shift;
	my $x = {major => 1,
		 minor => 1,
		 type => 'request',
		 method => $o->{method},
		 hf => [qw/Host User-Agent Accept-Encoding Connection/],
		 hv => {connection => 'keep-alive',
			'user-agent' => 'App-rs',
			'accept-encoding' => 'gzip'}};
	if ($o->{method} eq 'POST') {
		push @{$x->{hf}}, qw/Content-Length Content-Type/;
		add($x->{hv},
		    'content-length' => undef,
		    'content-type' => 'application/x-www-form-urlencoded');
		$x->{c} = $o->{'post-data'};
	}
	my $url = $o->{url};
	@$x{qw/protocol request-uri/} = ('http', '/');
	($x->{protocol}, $url) = ($1, $2) if $url =~ m|(.*)://(.*)|;
	if ($url =~ m|(.*?)(/.*)|) {
		($x->{hv}{host}, $x->{'request-uri'}) = ($1, $2);
	} else {
		$x->{hv}{host} = $url;
	}
	my $r = http_req($x);
	my $c = $r->{c};
	$c = memGunzip($c) if eval { $r->{hv}{'content-encoding'} eq 'gzip' };
	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}) . '-';
			}