view release on metacpan or  search on metacpan

lib/Perinci/Access/Simple/Client.pm  view on Meta::CPAN

sub _parse {
    my $self = shift;
    $self->_parse_or_request('parse2', @_);
}

# which: parse0 = quick parse (for parse_url(), parse2 = more thorough parse
# (for testing)
sub _parse_or_request {
    my ($self, $which, $action, $server_url, $extra) = @_;
    log_trace("=> %s\::request(action=%s, server_url=%s, extra=%s)",
                 __PACKAGE__, $action, $server_url, $extra);
    return [400, "Please specify server_url"] unless $server_url;

    my ($uri,
        $cache_key,
        $host, $port, # tcp
        $path,        # unix & pipe
        $args         # pipe
    );
    my ($srvsch, $srvauth, $srvpath, $srvquery, $srvfrag) =
        uri_split($server_url);
    $srvauth //= "";
    $srvpath //= "";
    return [400, "Please supply only riap+tcp/riap+unix/riap+pipe URL"]
        unless $srvsch =~ /\Ariap\+(tcp|unix|pipe)\z/;
    if ($srvsch eq 'riap+tcp') {
        if ($srvauth =~ m!^(.+):(\d+)$!) {
            ($host, $port) = ($1, $2, $3);
            $uri = $srvpath;
            $cache_key = "tcp:".lc($host).":$port";
        } else {
            return [400, "Invalid riap+tcp URL, please use this format: ".
                "riap+tcp://host:1234 or riap+tcp://host:1234/uri"];
        }
    } elsif ($srvsch eq 'riap+unix') {
        if ($srvpath =~ m!(.+)/(/.*)!) {
            ($path, $uri) = (uri_unescape($1), $2);
        } elsif ($srvpath =~ m!(.+)!) {
            $path = uri_unescape($1);
        }
        unless ($which eq 'parse0') {
            if (defined($path)) {
                my $apath = abs_path($path) or
                    return [500, "Can't find absolute path for $path"];
                $cache_key = "unix:$apath";
            } else {
                return [400, "Invalid riap+unix URL, please use this format: ".
                            ", e.g.: riap+unix:/path/to/unix/socket or ".
                                "riap+unix:/path/to/unix/socket//uri"];
            }
        }
    } elsif ($srvsch eq 'riap+pipe') {
        if ($srvpath =~ m!(.+?)//(.*?)/(/.*)!) {
            ($path, $args, $uri) = (uri_unescape($1), $2, $3);
        } elsif ($srvpath =~ m!(.+?)//(.*)!) {
            ($path, $args) = (uri_unescape($1), $2);
        } elsif ($srvpath =~ m!(.+)!) {
            $path = uri_unescape($1);
            $args = '';
        }
        $args = [map {uri_unescape($_)} split m!/!, $args // ''];
        unless ($which eq 'parse0') {
            if (defined($path)) {
                my $apath = abs_path($path) or
                    return [500, "Can't find absolute path for $path"];
                $cache_key = "pipe:$apath ".join(" ", @$args);
            } else {
                return [400, "Invalid riap+pipe URL, please use this format: ".
                            "riap+pipe:/path/to/prog or ".
                                "riap+pipe:/path/to/prog//arg1/arg2 or ".
                                    "riap+pipe:/path/to/prog//arg1/arg2//uri"];
            }
        }
    }

    my $req;
    my $res;

    unless ($which eq 'parse0') {
        $req = { v=>$self->{riap_version}, action=>$action, %{$extra // {}} };
        $uri ||= $req->{uri}; $req->{uri} //= $uri;
        $res = $self->check_request($req);
        return $res if $res;
    }

    if ($which =~ /parse/) {
        return [200, "OK", {
            args=>$args, host=>$host, path=>$path, port=>$port,
            scheme=>$srvsch, uri=>$uri,
        }];
    }

    log_trace("Parsed URI, scheme=%s, host=%s, port=%s, path=%s, args=%s, ".
                     "uri=%s", $srvsch, $host, $port, $path, $args, $uri);

    require JSON::MaybeXS;
    state $json = JSON::MaybeXS->new->allow_nonref;

    my $attempts = 0;
    my $do_retry;
    my $e;
    while (1) {
        $do_retry = 0;

        my ($in, $out);
        my $cache = $self->{_conns}{$cache_key};
        # check cache staleness
        if ($cache) {
            if ($srvsch =~ /tcp|unix/) {
                if ($cache->{socket}->connected) {
                    $in = $out = $cache->{socket};
                } else {
                    log_info("Stale socket cache (%s), discarded",
                                $cache_key);
                    $cache = undef;
                }
            } else {
                if (kill(0, $cache->{pid})) {
                    $in  = $cache->{chld_out};
                    $out = $cache->{chld_in};
                } else {