File Coverage

blib/lib/App/rs.pm

Criterion	Covered	Total	%
statement	65	332	19.5
branch	14	204	6.8
condition	2	38	5.2
subroutine	10	31	32.2
pod	0	20	0.0
total	91	625	14.5

=license

	Copyright © 2018 Yang Bo

	This file is part of RSLinux.

	RSLinux is free software: you can redistribute it and/or modify
	it under the terms of the GNU General Public License as published by
	the Free Software Foundation, either version 3 of the License, or
	(at your option) any later version.

	RSLinux is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	GNU General Public License for more details.

	You should have received a copy of the GNU General Public License
	along with RSLinux.  If not, see .

=cut

package App::rs;

our $VERSION = 'v2.1.2';

use strict;
use warnings qw/all FATAL uninitialized/;
use feature qw/state say/;

require XSLoader;
XSLoader::load();

sub _require ($) {
	my $r = shift =~ s|::|/|gr . '.pm';
	require $r if not $INC{$r};
}
sub flatten (;$) {
	my $v = @_ ? shift : $_;
	ref $v eq 'ARRAY' ? @$v : $v;
}
BEGIN {
	no strict 'refs';
	my @H = ($^H, ${^WARNING_BITS}, %^H);
	sub import {
		my $ns = caller . '::';
		shift;
		while (@_) {
			my $q = shift;
			if ($q eq 'iautoload') {
				my (@pkg, %map);
				for (@{+shift}) {
					my ($p, @f) = flatten;
					push @pkg, $p;
					for (@f) {
						my ($from, $to) = flatten;
						$from =~ s/^([$@%&*])//;
						$to ||= $from;
						if (my $s = $1) {
							state $sigil = {'$' => 'SCALAR',
									'@' => 'ARRAY',
									'%' => 'HASH',
									'&' => 'CODE',
									'*' => 'GLOB'};
							_require $p;
							*{$ns . $to} = *{"${p}::$from"}{$sigil->{$s}};
						} else {
							$map{$to} = {from => $from,
								     module => $p};
						}
					}
				}
				*{$ns . 'AUTOLOAD'} = sub {
					# "fully qualified name of the original subroutine".
					my $q = our $AUTOLOAD;
					# to avoid possibly overwrite @_ by successful regular expression match.
					my ($to) = do { $q =~ /.*::(.*)/ };
					my $u = $map{$to};
					my $from = $u->{from} || $to;
					for my $p ($u->{module} || @pkg) {
						#   calculate the actual file to be loaded thus avoid eval and
						# checking $@ mannually.
						_require $p;
						if (my $r = *{"${p}::$from"}{CODE}) {
							no warnings 'prototype';
							*$q = $r;
							# TODO: understand why using goto will lost context.
							#goto &$r;
							return &$r;
						}
					}
					confess("unable to autoload $q.");
				};
			} elsif ($q eq 'oautoload') {
				for my $p (@{+shift}) {
					my $r = $p =~ s|::|/|gr . '.pm';
					# ignore already loaded module.
					my $f = "${p}::AUTOLOAD";
					next if $INC{$r} or *$f{CODE};
					*$f = sub {
						my ($f) = do { our $AUTOLOAD =~ /.*::(.*)/ };
						my $symtab = *{"${p}::"}{HASH};
						delete $symtab->{AUTOLOAD};
						require $r;
						&{$symtab->{$f}};
					};
				}
			} elsif ($q eq 'sane') {
				($^H, ${^WARNING_BITS}, %^H) = @H;
			} else {
				confess("unknown request $q");
			}
		}
	};
	my @a = qw/Cpanel::JSON::XS JSON::XS JSON::PP/;
	App::rs->import(iautoload => ['Carp',
				      [qw'Compress::Zlib memGunzip'],
				      [qw/File::Path make_path/],
				      [qw'Socket getaddrinfo',
				       map { "&$_" } qw'AF_UNIX SOCK_STREAM MSG_NOSIGNAL']],
			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 }
	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}) . '-';
			}
			$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};
							} else {
								$h->{hv}{$k} .= $h->{l};
							}
						} else {
							my ($f, $v) = $h->{l} =~ /^(.*?)\s*:\s*(.*?)\s*$/;
							my $k = lc($f);
							if (exists $h->{hv}{$k}) {
								if (ref $h->{hv}{$k} eq "ARRAY") {
									push @{$h->{hv}{$k}}, $v;
								} else {
									$h->{hv}{$k} = [$h->{hv}{$k}, $v];
								}
							} else {
								$h->{hv}{$k} = $v;
							}
							push @{$h->{hf}}, $f;
						}
					}
				} elsif ($h->{st} eq "reading-chunk-size") {
					$h->{l} =~ /^([A-Fa-f0-9]+)/;
					if ($1 !~ /^0+$/)	{ $h->{rl} = hex $1, $h->{st} = "reading-chunk-data" }
					else			{ $h->{st} = "reading-trailer" }
				} elsif ($h->{st} eq "reading-crlf") {
					$h->{st} = "reading-chunk-size";
				} elsif ($h->{st} eq "reading-trailer") {
					# trailer ignored.
					return $i unless $h->{l};
				}
				$h->{l} = "";
			} else {
				$h->{l} .= substr($b, $i), $i = length($b);
			}
		} else {
			if ($h->{rl} ne "eof" and $h->{rl} <= length($b) - $i) {
				$h->{c} .= substr($b, $i, $h->{rl}), $i += $h->{rl};
				if ($h->{st} eq "reading-chunk-data")	{ $h->{rl} = "line", $h->{st} = "reading-crlf" }
				else					{ return $i }
			} else {
				$h->{c} .= substr($b, $i), $h->{rl} -= length($b) - $i, $i = length($b);
			}
		}
	}
	undef;
}
sub http_unparse {
	my $h = shift;
	my $b;
	my $v = "HTTP/$h->{major}.$h->{minor}";
	if ($h->{type} eq "request")	{ $b = join " ", $h->{method}, $h->{"request-uri"}, $v }
	else				{ $b = join " ", $v, $h->{"status-code"}, $h->{"reason-phrase"} }
	$b .= "\r\n";
	$h->{hv}{"content-length"} = length($h->{c}) if exists $h->{hv}{"content-length"};
	my $i = {};
	for (@{$h->{hf}}) {
		$b .= "$_: ";
		my $k = lc $_;
		if (ref $h->{hv}{$k} eq "ARRAY")	{ $b .= $h->{hv}{$k}[$i->{$k}++] }
		else					{ $b .= $h->{hv}{$k} }
		$b .= "\r\n";
	}
	$b .= "\r\n";
	if (exists $h->{c}) {
		if (exists $h->{hv}{"transfer-encoding"} and $h->{hv}{"transfer-encoding"} !~ /^identity$/i) {
			$b .= sprintf("%x\r\n", length($h->{c})) . $h->{c} . "\r\n0\r\n\r\n";
		} else {
			$b .= $h->{c};
		}
	}
	$b;
}
sub vcmp ($$) {
	my ($a, $b) = @_;
	version->parse($a) <=> version->parse($b);
}
sub vsat {
	my ($pkg, $ver) = @_;
	return vcmp($^V, $ver) >= 0 if $pkg eq 'perl';
	if (my $pid = fork) {
		die unless $pid == waitpid $pid, 0;
		not $?;
	} else {
		exit not eval {
			require $pkg =~ s|::|/|gr . '.pm';
			$pkg->VERSION($ver);
		};
	}
}
sub rf {
	local (@ARGV, $/) = @_;
	<>;
}
1;