File Coverage

blib/lib/Perinci/Access/Lite.pm

Criterion	Covered	Total	%
statement	92	130	70.7
branch	28	68	41.1
condition	20	41	48.7
subroutine	12	12	100.0
pod	2	2	100.0
total	154	253	60.8

package Perinci::Access::Lite;

our $DATE = '2015-12-17'; # DATE
our $VERSION = '0.12'; # VERSION

use 5.010001;
use strict;
use warnings;

use Perinci::AccessUtil qw(strip_riap_stuffs_from_res);

sub new {
    my ($class, %args) = @_;
    $args{riap_version} //= 1.1;
    bless \%args, $class;
}

# copy-pasted from SHARYANTO::Package::Util
sub __package_exists {
    no strict 'refs';

    my $pkg = shift;

    return unless $pkg =~ /\A\w+(::\w+)*\z/;
    if ($pkg =~ s/::(\w+)\z//) {
        return !!${$pkg . "::"}{$1 . "::"};
    } else {
        return !!$::{$pkg . "::"};
    }
}

sub request {
    no strict 'refs';

    my ($self, $action, $url, $extra) = @_;

    #say "D:request($action => $url)";

    $extra //= {};

    my $v = $extra->{v} // 1.1;
    if ($v ne '1.1' && $v ne '1.2') {
        return [501, "Riap protocol not supported, must be 1.1 or 1.2"];
    }

    my $res;
    if ($url =~ m!\A(?:pl:)?/(\w+(?:/\w+)*)/(\w*)\z!) {
        my ($mod_uripath, $func) = ($1, $2);
        (my $pkg = $mod_uripath) =~ s!/!::!g;
        my $mod_pm = "$mod_uripath.pm";

        my $pkg_exists;

      LOAD:
        {
            last if exists $INC{$mod_pm};
            $pkg_exists = __package_exists($pkg);
            # special names
            last LOAD if $pkg =~ /\A(main)\z/;
            last if $pkg_exists && defined(${"$pkg\::VERSION"});
            #say "D:Loading $pkg ...";
            eval { require $mod_pm };
            return [500, "Can't load module $pkg: $@"] if $@;
        }

        if ($action eq 'list') {
            return [501, "Action 'list' not implemented for ".
                        "non-package entities"]
                if length($func);
            no strict 'refs';
            my $spec = \%{"$pkg\::SPEC"};
            return [200, "OK (list)", [grep {/\A\w+\z/} sort keys %$spec]];
        } elsif ($action eq 'info') {
            my $data = {
                uri => "$mod_uripath/$func",
                type => (!length($func) ? "package" :
                             $func =~ /\A\w+\z/ ? "function" :
                                 $func =~ /\A[\@\$\%]/ ? "variable" :
                                     "?"),
            };
            return [200, "OK (info)", $data];
        } elsif ($action eq 'meta' || $action eq 'call') {
            return [501, "Action 'call' not implemented for package entity"]
                if !length($func) && $action eq 'call';
            my $meta;
            {
                no strict 'refs';
                if (length $func) {
                    $meta = ${"$pkg\::SPEC"}{$func}
                        or return [
                            500, "No metadata for '$url' (".
                                ($pkg_exists ? "package '$pkg' exists, perhaps you mentioned '$pkg' somewhere without actually loading the module, or perhaps '$func' is a typo?" :
                                     "package '$pkg' doesn't exist, perhaps '$mod_uripath' or '$func' is a typo?") .
                                ")"];
                } else {
                    $meta = ${"$pkg\::SPEC"}{':package'} // {v=>1.1};
                }
                $meta->{entity_v}    //= ${"$pkg\::VERSION"};
                $meta->{entity_date} //= ${"$pkg\::DATE"};
            }

            require Perinci::Sub::Normalize;
            $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
            if ($action eq 'meta') {
                $meta->{_orig_args_as} = $meta->{args_as};
                $meta->{args_as} = 'hash';
                $meta->{_orig_result_naked} = $meta->{result_naked};
                $meta->{result_naked} = 0;
                return [200, "OK ($action)", $meta];
            }

            # form args (and add special args)
            my $args = { %{$extra->{args} // {}} }; # shallow copy
            if ($meta->{features} && $meta->{features}{progress}) {
                require Progress::Any;
                $args->{-progress} = Progress::Any->get_indicator;
            }

            # convert args
            my $aa = $meta->{args_as} // 'hash';
            my @args;
            if ($aa =~ /array/) {
                require Perinci::Sub::ConvertArgs::Array;
                my $convres = Perinci::Sub::ConvertArgs::Array::convert_args_to_array(
                    args => $args, meta => $meta,
                );
                return $convres unless $convres->[0] == 200;
                if ($aa =~ /ref/) {
                    @args = ($convres->[2]);
                } else {
                    @args = @{ $convres->[2] };
                }
            } elsif ($aa eq 'hashref') {
                @args = ({ %$args });
            } else {
                # hash
                @args = %$args;
            }

            # call!
            {
                no strict 'refs';
                $res = &{"$pkg\::$func"}(@args);
            }

            # add envelope
            if ($meta->{result_naked}) {
                $res = [200, "OK (envelope added by ".__PACKAGE__.")", $res];
            }

            # add hint that result is binary
            if (defined $res->[2]) {
                if ($meta->{result} && $meta->{result}{schema} &&
                        $meta->{result}{schema}[0] eq 'buf') {
                    $res->[3]{'x.hint.result_binary'} = 1;
                }
            }

        } else {
            return [501, "Unknown/unsupported action '$action'"];
        }
    } elsif ($url =~ m!\Ahttps?:/(/?)!i) {
        my $is_unix = !$1;
        my $ht;
        require JSON;
        state $json = JSON->new->allow_nonref;
        if ($is_unix) {
            require HTTP::Tiny::UNIX;
            $ht = HTTP::Tiny::UNIX->new;
        } else {
            require HTTP::Tiny;
            $ht = HTTP::Tiny->new;
        }
        my %headers = (
            "x-riap-v" => $self->{riap_version},
            "x-riap-action" => $action,
            "x-riap-fmt" => "json",
            "content-type" => "application/json",
        );
        my $args = $extra->{args} // {};
        for (keys %$extra) {
            next if /\Aargs\z/;
            $headers{"x-riap-$_"} = $extra->{$_};
        }
        my $htres = $ht->post(
            $url, {
                headers => \%headers,
                content => $json->encode($args),
            });
        return [500, "Network error: $htres->{status} - $htres->{reason}"]
            if $htres->{status} != 200;
        return [500, "Server error: didn't return JSON (".$htres->{headers}{'content-type'}.")"]
            unless $htres->{headers}{'content-type'} eq 'application/json';
        return [500, "Server error: didn't return Riap 1.1 response (".$htres->{headers}{'x-riap-v'}.")"]
            unless $htres->{headers}{'x-riap-v'} =~ /\A1\.1(\.\d+)?\z/;
        $res = $json->decode($htres->{content});
    } else {
        return [501, "Unsupported scheme or bad URL '$url'"];
    }

    strip_riap_stuffs_from_res($res);
}

1;
# ABSTRACT: A lightweight Riap client library

__END__