File Coverage

blib/lib/Perinci/Access/Simple/Server/Pipe.pm
Criterion Covered Total %
statement 37 66 56.0
branch 1 12 8.3
condition 2 4 50.0
subroutine 11 12 91.6
pod 3 3 100.0
total 54 97 55.6


line stmt bran cond sub pod time code
1             package Perinci::Access::Simple::Server::Pipe;
2              
3             our $DATE = '2020-05-08'; # DATE
4             our $VERSION = '0.28'; # VERSION
5              
6 1     1   168657 use 5.010001;
  1         14  
7 1     1   6 use strict;
  1         4  
  1         42  
8 1     1   7 use warnings;
  1         1  
  1         30  
9 1     1   5 use Log::ger;
  1         1  
  1         6  
10              
11 1     1   797 use Data::Clean::FromJSON;
  1         3833  
  1         33  
12 1     1   464 use Data::Clean::JSON;
  1         460  
  1         46  
13 1     1   485 use JSON::MaybeXS;
  1         5899  
  1         66  
14 1     1   7 use Perinci::AccessUtil qw(insert_riap_stuffs_to_res decode_args_in_riap_req);
  1         2  
  1         93  
15              
16 1     1   537 use Moo;
  1         11650  
  1         8  
17              
18             has req => (is => 'rw'); # current Riap request
19             has res => (is => 'rw'); # current Riap response
20             has riap_client => (
21             is => 'rw',
22             lazy => 1,
23             default => sub {
24             require Perinci::Access::Schemeless;
25             Perinci::Access::Schemeless->new();
26             });
27              
28             my $json = JSON::MaybeXS->new->allow_nonref->canonical;
29             my $cleanser = Data::Clean::JSON->get_cleanser;
30             my $cleanserfj = Data::Clean::FromJSON->get_cleanser;
31              
32             $|++;
33              
34             # default handler
35              
36             sub handle {
37 1     1 1 297833 my ($self) = @_;
38 1         15 my $req = $self->req;
39              
40 1         120 my $res = $self->riap_client->request($req->{action} => $req->{uri}, $req);
41 1         141779 $self->res($res);
42             }
43              
44             sub send_response {
45 1     1 1 1934 my $self = shift;
46 1   50     15 my $res = $self->res // [500, "BUG: Response not set"];
47 1         6 log_trace("Sending response to stdout: %s", $res);
48 1 50 50     19 my $v = ($self->req ? $self->req->{v} : undef) // 1.1;
49 1         8 insert_riap_stuffs_to_res($res, $v);
50 1         65 $res = $cleanser->clone_and_clean($res);
51 1         536 print "j", $json->encode($res), "\015\012";
52             }
53              
54             sub run {
55 0     0 1   my $self = shift;
56 0           my $last;
57              
58 0           log_trace("Starting loop ...");
59              
60             REQ:
61 0           while (1) {
62 0           my $line = <STDIN>;
63 0           log_trace("Read line from stdin: %s", $line);
64 0 0         last REQ unless defined($line);
65 0           my $req_json;
66 0 0         if ($line =~ /\Aj(.*)/) {
67 0           $req_json = $1;
68             } else {
69 0           $self->res([400, "Invalid request line, use j<json>"]);
70 0           $last++;
71 0           goto RES;
72             }
73 0           log_trace("Read JSON from stdin: %s", $req_json);
74 0           my $req;
75 0           eval {
76 0           $req = $json->decode($req_json);
77 0           $cleanserfj->clean_in_place($req);
78 0           decode_args_in_riap_req($req);
79             };
80 0           my $e = $@;
81 0 0         if ($e) {
    0          
82             #$self->res([400, "Invalid JSON ($e)"]);
83 0           $self->res([400, "Invalid JSON"]);
84 0           goto RES;
85             } elsif (ref($req) ne 'HASH') {
86 0           $self->res([400, "Invalid request (not hash)"]);
87 0           goto RES;
88             }
89 0           $self->req($req);
90              
91 0           HANDLE:
92             $self->handle;
93              
94 0           RES:
95             $self->send_response;
96              
97 0 0         last if $last;
98             }
99             }
100              
101             1;
102             # ABSTRACT: (Base) class for creating Riap::Simple server over pipe
103              
104             __END__
105              
106             =pod
107              
108             =encoding UTF-8
109              
110             =head1 NAME
111              
112             Perinci::Access::Simple::Server::Pipe - (Base) class for creating Riap::Simple server over pipe
113              
114             =head1 VERSION
115              
116             This document describes version 0.28 of Perinci::Access::Simple::Server::Pipe (from Perl distribution Perinci-Access-Simple-Server), released on 2020-05-08.
117              
118             =head1 SYNOPSIS
119              
120             In C</path/to/your/program>:
121              
122             #!/usr/bin/perl
123             package MyRiapServer;
124             use Moo;
125             extends 'Perinci::Access::Simple::Server::Pipe';
126              
127             # override some methods ...
128              
129             package main;
130             MyRiapServer->run;
131              
132             Accessing the server via L<Perinci::Access>:
133              
134             % perl -MPerinci::Access -e'my $pa = Perinci::Access->new;
135             my $res = $pa->request(call => "riap+pipe:/path/to/your/prog////Foo/func");
136              
137             =head1 DESCRIPTION
138              
139             This module is a class for creating L<Riap::Simple> server over pipe. Riap
140             requests will be read from STDIN, and response sent to STDOUT.
141              
142             By default, the L<handle()> method processes the Riap request using
143             L<Perinci::Access::Schemeless>. You can customize this by overriding the method.
144             The Riap request is in C<req>. Method should set C<res> to the Riap response.
145              
146             =head1 ATTRIBUTES
147              
148             =head2 req => HASH
149              
150             The current Riap request.
151              
152             =head2 res => HASH
153              
154             The current Riap response.
155              
156             =head1 METHODS
157              
158             =for Pod::Coverage BUILD
159              
160             =head2 run()
161              
162             The main method. Will start a loop of reading request from STDIN and sending
163             response to STDOUT. Riap request will be put to C<req> attribute.
164              
165             =head2 handle()
166              
167             The method that will be called by run() to set C<res> attribute. By default it
168             will pass the request to L<Perinci::Access::Schemeless>. You can override this
169             method to provide custom behavior.
170              
171             =head2 send_response()
172              
173             The method that sends C<res> to client (STDOUT).
174              
175             =head1 HOMEPAGE
176              
177             Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Access-Simple-Server>.
178              
179             =head1 SOURCE
180              
181             Source repository is at L<https://github.com/perlancar/perl-Perinci-Access-Simple-Server>.
182              
183             =head1 BUGS
184              
185             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Access-Simple-Server>
186              
187             When submitting a bug or request, please include a test-file or a
188             patch to an existing test-file that illustrates the bug or desired
189             feature.
190              
191             =head1 SEE ALSO
192              
193             L<Riap::Simple>, L<Riap>, L<Rinci>
194              
195             L<Perinci::Access::Simple::Server::Socket>.
196              
197             =head1 AUTHOR
198              
199             perlancar <perlancar@cpan.org>
200              
201             =head1 COPYRIGHT AND LICENSE
202              
203             This software is copyright (c) 2020, 2017, 2015, 2014, 2013, 2012 by perlancar@cpan.org.
204              
205             This is free software; you can redistribute it and/or modify it under
206             the same terms as the Perl 5 programming language system itself.
207              
208             =cut