File Coverage

blib/lib/Perinci/Access/Schemeless.pm
Criterion Covered Total %
statement 434 538 80.6
branch 180 284 63.3
condition 85 116 73.2
subroutine 59 73 80.8
pod 3 43 6.9
total 761 1054 72.2


line stmt bran cond sub pod time code
1             package Perinci::Access::Schemeless;
2              
3             our $DATE = '2020-03-04'; # DATE
4             our $VERSION = '0.892'; # VERSION
5              
6 3     3   130714 use 5.010001;
  3         23  
7 3     3   12 use strict;
  3         6  
  3         51  
8 3     3   10 use warnings;
  3         5  
  3         96  
9 3     3   810 use experimental 'smartmatch';
  3         6018  
  3         23  
10 3     3   5878 use Log::ger;
  3         133  
  3         13  
11              
12 3     3   975 use parent qw(Perinci::Access::Base);
  3         240  
  3         17  
13              
14 3     3   9248 use List::Util qw(first);
  3         6  
  3         224  
15 3     3   1161 use Perinci::Object;
  3         1134  
  3         196  
16 3     3   1207 use Perinci::Sub::Normalize qw(normalize_function_metadata);
  3         3137  
  3         160  
17 3     3   1281 use Perinci::Sub::Util qw(err);
  3         5921  
  3         171  
18 3     3   19 use Scalar::Util qw(blessed);
  3         5  
  3         193  
19 3     3   1475 use Module::Path::More qw(module_path);
  3         3085  
  3         158  
20 3     3   1208 use Package::Util::Lite qw(package_exists);
  3         1143  
  3         151  
21 3     3   1250 use Tie::Cache;
  3         7150  
  3         86  
22 3     3   18 use URI::Split qw(uri_split uri_join);
  3         6  
  3         4556  
23              
24             our $re_perl_package =
25             qr/\A[A-Za-z_][A-Za-z_0-9]*(::[A-Za-z_0-9][A-Za-z_0-9]*)*\z/;
26              
27             sub new {
28 36     36 1 133940 require Class::Inspector;
29              
30 36         8887 my $class = shift;
31 36         150 my $self = $class->SUPER::new(@_);
32              
33             # build a list of supported actions for each type of entity
34 36         332 my %typeacts = (
35             package => [],
36             function => [],
37             variable => [],
38             ); # key = type, val = [[ACTION, META], ...]
39              
40 36         60 my @comacts;
41 36         53 for my $meth (@{Class::Inspector->methods(ref $self)}) {
  36         134  
42 2846 100       29204 next unless $meth =~ /^actionmeta_(.+)/;
43 685         1146 my $act = $1;
44 685         1341 my $meta = $self->$meth();
45 685         1148 $self->{_actionmetas}{$act} = $meta;
46 685         724 for my $type (@{$meta->{applies_to}}) {
  685         1020  
47 685 100       1058 if ($type eq '*') {
48 469         1090 push @comacts, [$act, $meta];
49             } else {
50 216         228 push @{$typeacts{$type}}, [$act, $meta];
  216         527  
51             }
52             }
53             }
54 36         198 for my $type (keys %typeacts) {
55 1623         2675 $typeacts{$type} = { map {$_->[0] => $_->[1]}
56 108         144 @{$typeacts{$type}}, @comacts };
  108         185  
57             }
58 36         80 $self->{_typeacts} = \%typeacts;
59              
60 36   50     158 $self->{cache_size} //= 100; # for caching metadata & code
61             #$self->{use_tx} //= 0;
62 36   100     133 $self->{wrap} //= 1;
63             #$self->{custom_tx_manager} //= undef;
64 36   50     133 $self->{load} //= 1;
65 36   100     140 $self->{normalize_metadata} //= 1;
66             #$self->{after_load}
67             #$self->{allow_paths}
68             #$self->{deny_paths}
69             #$self->{allow_schemes}
70             #$self->{deny_schemes}
71             #$self->{package_prefix}
72 36   50     221 $self->{debug} //= $ENV{PERINCI_ACCESS_SCHEMELESS_DEBUG} // 0;
      33        
73 36   50     135 $self->{accept_argv} //= 1;
74              
75 36 50       71 if ($self->{cache_size} > 0) {
76 36         46 my %metacache;
77 36         221 tie %metacache, 'Tie::Cache', $self->{cache_size};
78 36         845 $self->{_meta_cache} = \%metacache;
79 36         49 my %codecache;
80 36         88 tie %codecache, 'Tie::Cache', $self->{cache_size};
81 36         618 $self->{_code_cache} = \%codecache;
82             }
83              
84 36         164 $self;
85             }
86              
87             # for older Perinci::Access::Base 0.28-, to remove later
88       0     sub _init {}
89              
90             # if paths=/a/b, will match /a/b as well as /a/b/c
91             sub __match_paths {
92 30     30   1297 my ($path, $paths) = @_;
93              
94 30 100       108 my $pathslash = $path =~ m!/\z! ? $path : "$path/";
95              
96 30 50       74 for (ref($paths) eq 'ARRAY' ? @$paths : $paths) {
97 30 100       48 if (ref($_) eq 'Regexp') {
98 8 100       48 return 1 if $path =~ $_;
99             } else {
100 22 100       46 if (m!/\z!) {
101 10 100 100     47 return 1 if $_ eq $pathslash || index($pathslash, $_) == 0;
102             } else {
103 12         20 my $p = "$_/";
104 12 100 100     70 return 1 if $p eq $path || index($pathslash, $p) == 0;
105             }
106             }
107             }
108 15         49 0;
109             }
110              
111             # if paths=/a/b, will match /a/b as well as /a/b/c AS WELL AS /a and /. only
112             # suitable for 'list' action, e.g. allow_path is '/a/b' but we can do 'list /'
113             # and 'list /a' too (but not 'list /c').
114             sub __match_paths2 {
115 427     427   4305 my ($path, $paths) = @_;
116              
117 427 100       929 my $pathslash = $path =~ m!/\z! ? $path : "$path/";
118              
119 427 50       691 for (ref($paths) eq 'ARRAY' ? @$paths : $paths) {
120 427 100       616 if (ref($_) eq 'Regexp') {
121             # we can't match a regex against a string, so we just pass here
122 52         121 return 1;
123             } else {
124 375 100       494 if (m!/\z!) {
125 10 100 100     59 return 1 if $_ eq $pathslash || index($_, $pathslash) == 0 ||
      100        
126             index($pathslash, $_) == 0;
127             } else {
128 365         468 my $p = "$_/";
129 365 100 100     1498 return 1 if $p eq $path || index($p, $pathslash) == 0 ||
      100        
130             index($pathslash, $p) == 0 ;
131             }
132             }
133             }
134 299         634 0;
135             }
136              
137             sub _parse_uri {
138 84     84   166 my ($self, $req) = @_;
139              
140 84         178 my $path = $req->{-uri_path};
141 84 100       186 if (defined $self->{allow_paths}) {
142 5         10 my $allow;
143 5 100       15 if ($self->{_actionmetas}{$req->{action}}{allow_request_parent_path}) {
144 4         11 $allow = __match_paths2($path, $self->{allow_paths});
145             } else {
146 1         49 $allow = __match_paths($path, $self->{allow_paths});
147             }
148 5 100       13 return err(403, "Forbidden uri path (does not match allow_paths)")
149             unless $allow;
150             }
151 83 100 100     185 if (defined($self->{deny_paths}) &&
152             __match_paths($path, $self->{deny_paths})) {
153 1         5 return err(403, "Forbidden uri path (matches deny_paths)");
154             }
155              
156 82   100     250 my $sch = $req->{-uri_scheme} // "";
157 82 100 100     203 if (defined($self->{allow_schemes}) && !($sch ~~ $self->{allow_schemes})) {
158 3         10 return err(501,
159             "Unsupported uri scheme (does not match allow_schemes)");
160             }
161 79 100 100     186 if (defined($self->{deny_schemes}) && ($sch ~~ $self->{deny_schemes})) {
162 1         5 return err(501, "Unsupported uri scheme (matches deny_schemes)");
163             }
164              
165 78         138 my ($dir, $leaf, $perl_package);
166 78 50       301 if ($path =~ m!(.*)/(.*)!) {
167 78         191 $dir = $1;
168 78         150 $leaf = $2;
169             } else {
170 0         0 $dir = $path;
171 0         0 $leaf = '';
172             }
173 78         132 for ($perl_package) {
174 78         107 $_ = $dir;
175 78         227 s!^/+!!;
176 78         271 s!/+!::!g;
177 78 50       211 if (defined $self->{package_prefix}) {
178 0 0       0 $_ = $self->{package_prefix} . (length($_) ? "::":"") . $_;
179             }
180             }
181 78 50 66     563 return err(400, "Invalid perl package name: $perl_package")
182             if $perl_package && $perl_package !~ $re_perl_package;
183              
184 78         114 my $type;
185 78 100       155 if (length $leaf) {
186 43 100       90 if ($leaf =~ /^[%\@\$]/) {
187 2         5 $type = 'variable';
188             } else {
189 41         64 $type = 'function';
190             }
191             } else {
192 35         48 $type = 'package';
193             # make sure path ends in /, to ease processing
194 35 50       115 $req->{-uri_path} .= "/" unless $path =~ m!/\z!;
195             }
196              
197 78         140 $req->{-uri_dir} = $dir;
198 78         148 $req->{-uri_leaf} = $leaf;
199 78         115 $req->{-perl_package} = $perl_package;
200 78         104 $req->{-type} = $type;
201              
202             #$log->tracef("TMP: req=%s", $req);
203 78         147 return;
204             }
205              
206             # key = module_p, val = error resp or undef if successful
207             my %loadcache;
208             tie %loadcache, 'Tie::Cache', 200;
209              
210             sub _load_module {
211 65     65   132 my ($self, $req) = @_;
212              
213 65         109 my $pkg = $req->{-perl_package};
214              
215             # skip there is no module to load
216 65 100       123 return if !$pkg;
217              
218             # if we are instructed not to load any module, we just check via existence
219             # of packages
220 64 50       128 unless ($self->{load}) {
221 0 0       0 return if package_exists($pkg);
222 0         0 return err(500, "Package $pkg does not exist");
223             }
224              
225 64         95 my $module_p = $pkg;
226 64         246 $module_p =~ s!::!/!g;
227 64         105 $module_p .= ".pm";
228              
229             # module has been required before and successfully loaded
230 64 100       161 return if $INC{$module_p};
231              
232             # module has been required before and failed
233             return err(500, "Module $pkg has failed to load previously" .
234             $loadcache{$module_p} ?
235             ": $loadcache{$module_p}[0] - $loadcache{$module_p}[1]" :
236             "")
237 46 50       88 if exists($INC{$module_p});
    100          
238              
239             # use cache result (for caching errors, or packages like 'main' and 'CORE'
240             # where no modules for such packages exist)
241 45 100       229 return $loadcache{$module_p} if exists $loadcache{$module_p};
242              
243             # load and cache negative result
244 41         268 my $res;
245             {
246 41         53 my $fullpath = module_path(module=>$pkg, find_pmc=>0, find_prefix=>1);
  41         128  
247              
248             # when the module path does not exist, but the package does, we can
249             # ignore this error. for example: main, CORE, etc.
250 41         12271 my $pkg_exists = package_exists($pkg);
251              
252 41 100       680 if (!$fullpath) {
    100          
253 30 100       83 last if $pkg_exists;
254 1         4 $res = [404, "Can't find module or prefix path for package $pkg"];
255 1         2 last;
256             } elsif ($fullpath !~ /\.pm$/) {
257 7 50       22 last if $pkg_exists;
258 0         0 $res = [405, "Can only find a prefix path for package $pkg"];
259 0         0 last;
260             }
261 4         7 eval { require $module_p };
  4         2809  
262 4 100       9403 if ($@) {
263 1         8 $res = [500, "Can't load module $pkg (probably compile error): $@"];
264 1         31 last;
265             }
266             # load is successful
267 3 100       12 if ($self->{after_load}) {
268 1         1 eval { $self->{after_load}($self, module=>$pkg) };
  1         4  
269 1 50       5 log_error("after_load for package $pkg dies: $@") if $@;
270             }
271             }
272 41         202 $loadcache{$module_p} = $res;
273 41         430 return $res;
274             }
275              
276             sub __inject_entity_v_date {
277 3     3   21 no strict 'refs';
  3         12  
  3         388  
278              
279 44     44   81 my ($req, $meta) = @_;
280              
281 44         70 my $pkg = $req->{-perl_package};
282 44 100       90 unless (defined $meta->{entity_v}) {
283 38         52 my $ver = ${"$pkg\::VERSION"};
  38         126  
284 38 100       76 if (defined $ver) {
285 25         51 $meta->{entity_v} = $ver;
286             }
287             }
288 44 100       94 unless (defined $meta->{entity_date}) {
289 41         52 my $date = ${"$pkg\::DATE"};
  41         103  
290 41 100       114 if (defined $date) {
291 13         27 $meta->{entity_date} = $date;
292             }
293             }
294             }
295              
296             sub get_meta {
297 3     3   20 no strict 'refs';
  3         18  
  3         1825  
298              
299 64     64 0 96 my ($self, $req) = @_;
300              
301 64         99 my $pkg = $req->{-perl_package};
302 64         84 my $leaf = $req->{-uri_leaf};
303 64         110 my $type = $req->{-type};
304 64 100       124 if (!length($pkg)) {
305 5 100       10 if (length $leaf) {
306             # 404 for all non-subpackage entity directly under /
307 1 50       5 return [404, "No metadata for ::$leaf (".
308             (package_exists($pkg) ? "package '$pkg' exists, perhaps you mentioned '$pkg' somewhere without actually loading the module, or perhaps '$leaf' is a typo?" :
309             "package '$pkg' doesn't exist, perhaps '$pkg' or '$leaf' is a typo?").
310             ")"
311             ];
312             } else {
313             # empty metadata for root (/)
314 4         10 $req->{-meta} = {v=>1.1};
315 4         9 return;
316             }
317             }
318              
319 59         106 my $name = "$pkg\::$leaf";
320 59 100       291 if ($self->{_meta_cache}{$name}) {
321 17         326 $req->{-meta} = $self->{_meta_cache}{$name};
322             $req->{-orig_meta} = $self->{_orig_meta_cache}{$name}
323 17 50       217 if $self->{_orig_meta_cache}{$name};
324 17         39 return;
325             }
326              
327 42         588 my $res = $self->_load_module($req);
328             # missing module (but existing prefix) is okay for package, we construct an
329             # empty package metadata for it
330 42 100 33     249 return $res if $res && !($type eq 'package' && $res->[0] == 405);
      66        
331              
332 36         121 my $meta;
333 36         44 my $metas = \%{"$pkg\::SPEC"};
  36         125  
334 36   100     125 $meta = $metas->{ $leaf || ":package" };
335              
336 36 100 100     117 if (!$meta && $type eq 'package') {
337 6         15 $meta = {v=>1.1};
338             }
339              
340 36 100       109 return err(404,
341             join("",
342             "No metadata for $name (package '$pkg' exists, ",
343             "perhaps you mentioned '$pkg' ",
344             "somewhere without actually loading the module, or ",
345             "perhaps '$leaf' is a typo?)",
346             )) unless $meta;
347              
348 33 50       63 if ($res) {
349 0 0       0 if ($res->[0] == 405) {
    0          
350 0         0 $meta = {v=>1.1}; # empty package metadata for dir
351             } elsif ($res->[0] != 200) {
352 0         0 return $res;
353             }
354             }
355              
356             # normalize has only been implemented for function
357 33 100 100     112 if ($type eq 'function' && $self->{normalize_metadata}) {
358 18         31 eval { $meta = normalize_function_metadata($meta) };
  18         57  
359 18 50       8682 if ($@) {
360 0         0 return [500, "Can't normalize function metadata: $@"];
361             }
362              
363 18   100     72 $meta->{args} //= {};
364 18         36 $meta->{_orig_args_as} = $meta->{args_as};
365 18         32 $meta->{args_as} = 'hash';
366 18         36 $meta->{_orig_result_naked} = $meta->{result_naked};
367 18         36 $meta->{result_naked} = 0;
368 18         28 my $sfp = $self->{set_function_properties};
369 18 50       39 if ($sfp) {
370 0         0 for (keys %$sfp) {
371 0         0 $meta->{"_orig_$_"} = $meta->{$_};
372 0         0 $meta->{$_} = $sfp->{$_};
373             }
374             }
375             }
376              
377 33         91 __inject_entity_v_date($req, $meta);
378              
379 33 50       71 if ($self->{cache_size} > 0) {
380 33         127 $self->{_meta_cache}{$name} = $meta;
381             }
382              
383 33         1347 $req->{-meta} = $meta;
384 33         63 return;
385             }
386              
387             sub get_code {
388 19     19 0 32 my ($self, $req) = @_;
389              
390             # because we're lazy, we assume here that type is already function. it
391             # should be okay since get_code() is only called by action_call().
392              
393 19         49 my $name = $req->{-perl_package} . "::" . $req->{-uri_leaf};
394 19 100       54 if ($self->{_code_cache}{$name}) {
395 6         88 $req->{-code} = $self->{_code_cache}{$name};
396 6         63 return;
397             }
398              
399 13         192 my $res = $self->_load_module($req);
400 13 50       31 return $res if $res;
401              
402             return err(404, "Can't find function $req->{-uri_leaf} in ".
403             "module $req->{-perl_package}")
404 13 50       23 unless defined &{$name};
  13         51  
405              
406             # we get our own meta and not use get_meta() because we want to get the
407             # original metadata
408 13         24 my $meta;
409             {
410 3     3   20 no strict 'refs';
  3         6  
  3         1030  
  13         20  
411 13         16 my $metas = \%{"$req->{-perl_package}::SPEC"};
  13         40  
412 13   50     43 $meta = $metas->{ $req->{-uri_leaf} || ":package" };
413             }
414              
415 13 50       31 return err(404, "Can't find function metadata $req->{-uri_leaf} in ".
416             "module $req->{-perl_package}")
417             unless $meta;
418              
419 13         18 my $code;
420             GET_CODE:
421             {
422             # we don't need to wrap
423 13 100 66     23 if (!$self->{wrap} ||
  13   100     61  
424             $meta->{"x.perinci.sub.wrapper.logs"} &&
425 1     1   6 (first {$_->{validate_args}}
426 1         6 @{ $meta->{"x.perinci.sub.wrapper.logs"} })
427             ) {
428 2         5 $code = \&{$name};
  2         6  
429 2         4 last GET_CODE;
430             }
431              
432 11         1034 require Perinci::Sub::Wrapper;
433 11         10460 my $sfp = $self->{set_function_properties};
434              
435 11 50       59 my $wrapres = Perinci::Sub::Wrapper::wrap_sub(
436             sub_name=>$name, meta=>$meta,
437             convert=>{args_as=>'hash', result_naked=>0,
438             ($sfp ? %$sfp : ())
439             });
440 11 50       150985 return err(500, "Can't wrap function", $wrapres)
441             unless $wrapres->[0] == 200;
442 11         26 $code = $wrapres->[2]{sub};
443              
444 11 50       35 if ($self->{cache_size} > 0) {
445 11         76 $self->{_code_cache}{$name} = $code;
446             # also put wrapper-generated meta in the cache, so further meta
447             # request can use this. the metadata from wrapper contains wrapper
448             # logs (x.perinci.sub.wrapper.logs) which can be helpful hint for
449             # some uses.
450 11         468 my $newmeta = $wrapres->[2]{meta};
451 11         29 $newmeta->{_orig_result_naked} = $meta->{result_naked};
452 11         23 $newmeta->{_orig_args_as} = $meta->{args_as};
453 11 50       31 if ($sfp) {
454 0         0 for (keys %$sfp) {
455 0         0 $newmeta->{"_orig_$_"} = $meta->{$_};
456             }
457             }
458 11         31 __inject_entity_v_date($req, $newmeta);
459 11         40 $self->{_meta_cache}{$name} = $newmeta;
460             }
461             }
462              
463 13         605 $req->{-code} = $code;
464 13         29 return;
465             }
466              
467             sub request {
468 3     3   20 no strict 'refs';
  3         5  
  3         2534  
469              
470 85     85 1 203357 my ($self, $action, $uri, $extra) = @_;
471              
472 85 50       243 return err(400, "Please specify URI") unless $uri;
473              
474 85   100     118 my $req = { action=>$action, uri=>$uri, %{$extra // {}} };
  85         408  
475 85         309 my $res = $self->check_request($req);
476 85 50       2634 return $res if $res;
477              
478 85 100       413 return err(501, "Action '$action' not implemented")
479             unless $self->can("actionmeta_$action");
480              
481 84         132 my $am = $self->${\("actionmeta_$action")};
  84         255  
482              
483 84         215 $res = $self->_parse_uri($req);
484 84 100       457 return $res if $res;
485              
486             return err(501, "Action '$action' not implemented for ".
487             "'$req->{-type}' entity")
488             unless $am->{applies_to}[0] eq '*' ||
489 78 100 100     198 $req->{-type} ~~ @{ $am->{applies_to} };
  36         169  
490              
491 76         139 my $meth = "action_$action";
492             # check transaction
493              
494 76         195 $res = $self->$meth($req);
495 76 50       2251 if ($self->{debug}) {
496 0   0     0 $res->[3] //= {};
497             $res->[3]{debug} = {
498 0         0 req => $req,
499             };
500             }
501 76         441 $res;
502             }
503              
504             sub parse_url {
505 2     2 1 9 my ($self, $uri) = @_;
506 2 50       5 die "Please specify url" unless $uri;
507 2         7 my ($sch, $auth, $path) = uri_split($uri);
508             return {
509             # to mark that we are schemeless
510 2         28 proto=>'',
511             path=>$path,
512             };
513             }
514              
515             sub actionmeta_info { +{
516 45     45 0 141 applies_to => ['*'],
517             summary => "Get general information on code entity",
518             needs_meta => 0,
519             needs_code => 0,
520             } }
521              
522             sub action_info {
523 7     7 0 15 my ($self, $req) = @_;
524              
525 7         18 my $mres = $self->get_meta($req);
526 7 100       17 return $mres if $mres;
527              
528             my $res = {
529             uri => $req->{uri},
530             type => $req->{-type},
531 6         16 };
532              
533 6         13 [200, "OK (info action)", $res];
534             }
535              
536             sub actionmeta_actions { +{
537 44     44 0 171 applies_to => ['*'],
538             summary => "List available actions for code entity",
539             needs_meta => 0,
540             needs_code => 0,
541             } }
542              
543             sub action_actions {
544 8     8 0 16 my ($self, $req) = @_;
545              
546 8         17 my $mres = $self->get_meta($req);
547 8 100       21 return $mres if $mres;
548              
549 4         7 my @res;
550 4         6 for my $k (sort keys %{ $self->{_typeacts}{$req->{-type}} }) {
  4         35  
551 60         85 my $v = $self->{_typeacts}{$req->{-type}}{$k};
552 60 50       87 if ($req->{detail}) {
553 0         0 push @res, {name=>$k, summary=>$v->{summary}};
554             } else {
555 60         81 push @res, $k;
556             }
557             }
558 4         13 [200, "OK (actions action)", \@res];
559             }
560              
561             sub actionmeta_list { +{
562 46     46 0 152 applies_to => ['package'],
563             summary => "List code entities inside this package code entity",
564             # this means, even if allow_path is '/a/b', we allow request on '/a' or '/'.
565             allow_request_parent_path => 1,
566             } }
567              
568             sub action_list {
569 10     10 0 998 require Module::List;
570              
571 10         10149 my ($self, $req) = @_;
572 10         23 my $detail = $req->{detail};
573 10   50     35 my $f_type = $req->{type} || "";
574              
575 10         20 my @res;
576              
577             my $filter_path = sub {
578 501     501   590 my $path = shift;
579 501 100 100     934 if (defined($self->{allow_paths}) &&
580             !__match_paths2($path, $self->{allow_paths})) {
581 296         669 return 0;
582             }
583 205 100 66     347 if (defined($self->{deny_paths}) &&
584             __match_paths2($path, $self->{deny_paths})) {
585 48         90 return 0;
586             }
587 157         251 1;
588 10         38 };
589              
590 10         16 my %mem;
591              
592             # get submodules
593 10 50 33     27 unless ($f_type && $f_type ne 'package') {
594             my $lres = Module::List::list_modules(
595 10 100       65 $req->{-perl_package} ? "$req->{-perl_package}\::" : "",
596             {list_modules=>1, list_prefixes=>1});
597 10         19062 my $dir = $req->{-uri_dir};
598 10         203 for my $m (sort keys %$lres) {
599 377         684 $m =~ s!::$!!;
600 377         646 $m =~ s!.+::!!;
601 377         578 my $path = "$dir/$m/";
602 377 100       543 next unless $filter_path->($path);
603 62 100       140 next if $mem{$path}++;
604 58 100       86 if ($detail) {
605 18         53 push @res, {uri=>"$m/", type=>"package"};
606             } else {
607 40         81 push @res, "$m/";
608             }
609             }
610             }
611              
612 10         66 my $res = $self->_load_module($req);
613 10 100 66     100 return $res if $res && $res->[0] != 405;
614              
615             # get all entities from this module
616 3     3   21 no strict 'refs';
  3         7  
  3         3651  
617 9         15 my $spec = \%{"$req->{-perl_package}\::SPEC"};
  9         43  
618 9         15 my $dir = $req->{-uri_dir};
619 9         87 for my $e (sort keys %$spec) {
620 130 100       236 next if $e =~ /^:/;
621 124         185 my $path = "$dir/$e";
622 124 100       159 next unless $filter_path->($path);
623 95 50       235 next if $mem{$path}++;
624 95 100       175 my $t = $e =~ /^[%\@\$]/ ? 'variable' : 'function';
625 95 50 33     158 next if $f_type && $f_type ne $t;
626 95 100       121 if ($detail) {
627 29         94 push @res, {
628             uri=>$e, type=>$t,
629             };
630             } else {
631 66         111 push @res, $e;
632             }
633             }
634              
635 9         79 [200, "OK (list action)", \@res];
636             }
637              
638             sub actionmeta_meta { +{
639 66     66 0 176 applies_to => ['*'],
640             summary => "Get metadata",
641             } }
642              
643             sub action_meta {
644 26     26 0 47 my ($self, $req) = @_;
645              
646 26         57 my $res = $self->get_meta($req);
647 26 100       525 return $res if $res;
648              
649 21         46 [200, "OK (meta action)", $req->{-meta}];
650             }
651              
652             sub actionmeta_call { +{
653 56     56 0 151 applies_to => ['function'],
654             summary => "Call function",
655             } }
656              
657             sub action_call {
658 19     19 0 990 require UUID::Random;
659              
660 19         218 my ($self, $req) = @_;
661              
662 19         30 my $res;
663              
664             my $tm; # = does client mention tx_id?
665 19 50       42 if (defined $req->{tx_id}) {
666 0         0 $res = $self->_pre_tx_action($req);
667 0 0       0 return $res if $res;
668 0         0 $tm = $self->{_tx_manager};
669 0         0 $tm->{_tx_id} = $req->{tx_id};
670             }
671              
672 19         51 $res = $self->get_meta($req);
673 19 50       42 return $res if $res;
674 19         45 $res = $self->get_code($req);
675 19 50       45 return $res if $res;
676              
677 19         30 my %args;
678              
679             # try to convert from argv if given argv
680 19 100 66     66 if (exists($req->{argv}) && $self->{accept_argv}) {
681 2         1574 require Perinci::Sub::GetArgs::Argv;
682             $res = Perinci::Sub::GetArgs::Argv::get_args_from_argv(
683 2         10 argv => [@{ $req->{argv} }],
684             meta => $req->{-meta},
685 2         12309 );
686 2 100       11756 return err(400, "Can't parse argv", $res) unless $res->[0] == 200;
687 1         2 %args = %{ $res->[2] };
  1         4  
688             } else {
689 17   100     24 %args = %{ $req->{args} // {} };
  17         84  
690             }
691              
692 18         67 my $risub = risub($req->{-meta});
693              
694 18 100       2749 if ($req->{dry_run}) {
695 3 100       9 return err(412, "Function does not support dry run")
696             unless $risub->can_dry_run;
697 2 100       19 if ($risub->feature('dry_run')) {
698 1         11 $args{-dry_run} = 1;
699             } else {
700 1         9 $args{-dry_run} = 1;
701 1         3 $args{-tx_action} = 'check_state';
702 1         4 $args{-tx_action_id} = UUID::Random::generate();
703 1         43 undef $tm;
704             }
705             }
706              
707 17 100       50 if ($risub->feature('progress')) {
708 1         6174 require Progress::Any;
709 1         6900 $args{-progress} = Progress::Any->get_indicator();
710             }
711              
712 17 50       267 if ($tm) {
713             $res = $tm->action(
714             f => "$req->{-perl_package}::$req->{-uri_leaf}", args=>\%args,
715             confirm => $req->{confirm},
716 0         0 );
717 0 0       0 $tm->{_tx_id} = undef if $tm;
718             } else {
719 17 100       46 $args{-confirm} = 1 if $req->{confirm};
720 17         28 eval { $res = $req->{-code}->(%args) };
  17         348  
721 17         709 my $eval_err = $@;
722 17 100       41 if ($eval_err) {
723 1         7 $res = err(500, "Function died: $eval_err");
724             }
725             }
726              
727             # add hint that result is binary
728 17 100       90 if (defined $res->[2]) {
729 7 50 66     43 if ($req->{-meta}{result} && $req->{-meta}{result}{schema} &&
      33        
730             $req->{-meta}{result}{schema}[0] eq 'buf') {
731 0         0 $res->[3]{'x.hint.result_binary'} = 1;
732             }
733             }
734              
735 17         51 $res;
736             }
737              
738             sub actionmeta_complete_arg_val { +{
739 41     41 0 117 applies_to => ['function'],
740             summary => "Complete function's argument value"
741             } }
742              
743             sub action_complete_arg_val {
744 5     5 0 1132 require Perinci::Sub::Complete;
745              
746 5         13021 my ($self, $req) = @_;
747 5 100       28 my $arg = $req->{arg} or return err(400, "Please specify arg");
748 4   100     13 my $word = $req->{word} // "";
749 4         7 my $ci = $req->{ci};
750              
751 4         10 my $res = $self->get_meta($req);
752 4 50       9 return $res if $res;
753             [200, "OK (complete_arg_val action)",
754 4   100     13 Perinci::Sub::Complete::complete_arg_val(meta=>$req->{-meta}, word=>$word,
755             arg=>$arg, ci=>$ci) // []];
756             }
757              
758             sub actionmeta_complete_arg_elem { +{
759 36     36 0 88 applies_to => ['function'],
760             summary => "Complete function's argument element value"
761             } }
762              
763             sub action_complete_arg_elem {
764 0     0 0 0 require Perinci::Sub::Complete;
765              
766 0         0 my ($self, $req) = @_;
767 0 0       0 my $arg = $req->{arg} or return err(400, "Please specify arg");
768             defined(my $index = $req->{index})
769 0 0       0 or return err(400, "Please specify index");
770 0   0     0 my $word = $req->{word} // "";
771 0         0 my $ci = $req->{ci};
772              
773 0         0 my $res = $self->get_meta($req);
774 0 0       0 return $res if $res;
775             [200, "OK (complete_arg_elem action)",
776             Perinci::Sub::Complete::complete_arg_elem(
777 0   0     0 meta=>$req->{-meta}, word=>$word, arg=>$arg, ci=>$ci, index=>$index,
778             ) // []];
779             }
780              
781             sub actionmeta_child_metas { +{
782 37     37 0 100 applies_to => ['package'],
783             summary => "Get metadata of all child entities",
784             } }
785              
786             sub action_child_metas {
787 1     1 0 3 my ($self, $req) = @_;
788              
789 1         5 my $res = $self->action_list($req);
790 1 50       5 return $res unless $res->[0] == 200;
791 1         3 my $ents = $res->[2];
792              
793 1         3 my %res;
794             my %om;
795             my $base = uri_join(
796 1         5 $req->{-uri_scheme}, $req->{-uri_auth}, $req->{-uri_dir});
797              
798 1         21 for my $ent (@$ents) {
799 6         22 $res = $self->request(meta => "$base/$ent");
800             # ignore failed request
801 6 50       13 next unless $res->[0] == 200;
802 6         10 $res{$ent} = $res->[2];
803             }
804 1         4 [200, "OK (child_metas action)", \%res];
805             }
806              
807             sub actionmeta_get { +{
808 36     36 0 121 applies_to => ['variable'],
809             summary => "Get value of variable",
810             } }
811              
812             sub action_get {
813 3     3   22 no strict 'refs';
  3         12  
  3         3361  
814              
815 0     0 0 0 my ($self, $req) = @_;
816 0         0 local $req->{-uri_leaf} = $req->{-uri_leaf};
817              
818             # extract prefix
819 0 0       0 $req->{-uri_leaf} =~ s/^([%\@\$])//
820             or return err(500, "BUG: Unknown variable prefix");
821 0         0 my $prefix = $1;
822 0         0 my $name = $req->{-perl_package} . "::" . $req->{-uri_leaf};
823             my $res =
824 0         0 $prefix eq '$' ? ${$name} :
825 0         0 $prefix eq '@' ? \@{$name} :
826 0 0       0 $prefix eq '%' ? \%{$name} :
  0 0       0  
    0          
827             undef;
828 0         0 [200, "OK (get action)", $res];
829             }
830              
831             sub _pre_tx_action {
832 0     0   0 my ($self, $req) = @_;
833              
834             return err(501, "Transaction not supported by server")
835 0 0       0 unless $self->{use_tx};
836              
837             # instantiate custom tx manager, per request if necessary
838 0 0       0 if (ref($self->{custom_tx_manager}) eq 'CODE') {
    0          
839 0         0 eval {
840 0         0 $self->{_tx_manager} = $self->{custom_tx_manager}->($self);
841 0 0       0 die $self->{_tx_manager} unless blessed($self->{_tx_manager});
842             };
843 0 0       0 return err(500, "Can't initialize custom tx manager: ".
844             "$self->{_tx_manager}: $@") if $@;
845             } elsif (!blessed($self->{_tx_manager})) {
846 0   0     0 my $tm_cl = $self->{custom_tx_manager} // "Perinci::Tx::Manager";
847 0         0 my $tm_cl_p = $tm_cl; $tm_cl_p =~ s!::!/!g; $tm_cl_p .= ".pm";
  0         0  
  0         0  
848 0         0 eval {
849 0         0 require $tm_cl_p;
850 0         0 $self->{_tx_manager} = $tm_cl->new(pa => $self);
851 0 0       0 die $self->{_tx_manager} unless blessed($self->{_tx_manager});
852             };
853 0 0       0 return err(500, "Can't initialize tx manager ($tm_cl): $@") if $@;
854             # we just want to force newer version, we currently can't specify this
855             # in Makefile.PL because peritm's tests use us. this might be rectified
856             # in the future.
857 0 0       0 if ($tm_cl eq 'Perinci::Tx::Manager') {
858 0 0       0 $Perinci::Tx::Manager::VERSION >= 0.29
859             or die "Your Perinci::Tx::Manager is too old, ".
860             "please install v0.29 or later";
861             }
862             }
863              
864 0         0 return;
865             }
866              
867             sub actionmeta_begin_tx { +{
868 36     36 0 115 applies_to => ['*'],
869             summary => "Start a new transaction",
870             } }
871              
872             sub action_begin_tx {
873 0     0 0 0 my ($self, $req) = @_;
874 0         0 my $res = $self->_pre_tx_action($req);
875 0 0       0 return $res if $res;
876              
877             $self->{_tx_manager}->begin(
878             tx_id => $req->{tx_id},
879             summary => $req->{summary},
880 0         0 );
881             }
882              
883             sub actionmeta_commit_tx { +{
884 36     36 0 86 applies_to => ['*'],
885             summary => "Commit a transaction",
886             } }
887              
888             sub action_commit_tx {
889 0     0 0 0 my ($self, $req) = @_;
890 0         0 my $res = $self->_pre_tx_action($req);
891 0 0       0 return $res if $res;
892              
893             $self->{_tx_manager}->commit(
894             tx_id => $req->{tx_id},
895 0         0 );
896             }
897              
898             sub actionmeta_savepoint_tx { +{
899 36     36 0 92 applies_to => ['*'],
900             summary => "Create a savepoint in a transaction",
901             } }
902              
903             sub action_savepoint_tx {
904 0     0 0 0 my ($self, $req) = @_;
905 0         0 my $res = $self->_pre_tx_action($req);
906 0 0       0 return $res if $res;
907              
908             $self->{_tx_manager}->savepoint(
909             tx_id => $req->{tx_id},
910             sp => $req->{tx_spid},
911 0         0 );
912             }
913              
914             sub actionmeta_release_tx_savepoint { +{
915 36     36 0 116 applies_to => ['*'],
916             summary => "Release a transaction savepoint",
917             } }
918              
919             sub action_release_tx_savepoint {
920 0     0 0 0 my ($self, $req) =\ @_;
921 0         0 my $res = $self->_pre_tx_action($req);
922 0 0       0 return $res if $res;
923              
924             $self->{_tx_manager}->release_savepoint(
925             tx_id => $req->{tx_id},
926             sp => $req->{tx_spid},
927 0         0 );
928             }
929              
930             sub actionmeta_rollback_tx { +{
931 36     36 0 117 applies_to => ['*'],
932             summary => "Rollback a transaction (optionally to a savepoint)",
933             } }
934              
935             sub action_rollback_tx {
936 0     0 0 0 my ($self, $req) = @_;
937 0         0 my $res = $self->_pre_tx_action($req);
938 0 0       0 return $res if $res;
939              
940             $self->{_tx_manager}->rollback(
941             tx_id => $req->{tx_id},
942             sp => $req->{tx_spid},
943 0         0 );
944             }
945              
946             sub actionmeta_list_txs { +{
947 36     36 0 88 applies_to => ['*'],
948             summary => "List transactions",
949             } }
950              
951             sub action_list_txs {
952 0     0 0 0 my ($self, $req) = @_;
953 0         0 my $res = $self->_pre_tx_action($req);
954 0 0       0 return $res if $res;
955              
956             $self->{_tx_manager}->list(
957             detail => $req->{detail},
958             tx_status => $req->{tx_status},
959             tx_id => $req->{tx_id},
960 0         0 );
961             }
962              
963             sub actionmeta_undo { +{
964 36     36 0 113 applies_to => ['*'],
965             summary => "Undo a committed transaction",
966             } }
967              
968             sub action_undo {
969 0     0 0 0 my ($self, $req) = @_;
970 0         0 my $res = $self->_pre_tx_action($req);
971 0 0       0 return $res if $res;
972              
973             $self->{_tx_manager}->undo(
974             tx_id => $req->{tx_id},
975             confirm => $req->{confirm},
976 0         0 );
977             }
978              
979             sub actionmeta_redo { +{
980 36     36 0 98 applies_to => ['*'],
981             summary => "Redo an undone committed transaction",
982             } }
983              
984             sub action_redo {
985 0     0 0 0 my ($self, $req) = @_;
986 0         0 my $res = $self->_pre_tx_action($req);
987 0 0       0 return $res if $res;
988              
989             $self->{_tx_manager}->redo(
990             tx_id => $req->{tx_id},
991             confirm => $req->{confirm},
992 0         0 );
993             }
994              
995             sub actionmeta_discard_tx { +{
996 36     36 0 85 applies_to => ['*'],
997             summary => "Discard (forget) a committed transaction",
998             } }
999              
1000             sub action_discard_tx {
1001 0     0 0 0 my ($self, $req) = @_;
1002 0         0 my $res = $self->_pre_tx_action($req);
1003 0 0       0 return $res if $res;
1004              
1005             $self->{_tx_manager}->discard(
1006             tx_id => $req->{tx_id},
1007 0         0 );
1008             }
1009              
1010             sub actionmeta_discard_all_txs { +{
1011 36     36 0 96 applies_to => ['*'],
1012             summary => "Discard (forget) all committed transactions",
1013             } }
1014              
1015             sub action_discard_all_txs {
1016 0     0 0   my ($self, $req) = @_;
1017 0           my $res = $self->_pre_tx_action($req);
1018 0 0         return $res if $res;
1019              
1020             $self->{_tx_manager}->discard_all(
1021             # XXX select client
1022 0           );
1023             }
1024              
1025             1;
1026             # ABSTRACT: Base class for Perinci::Access::Perl
1027              
1028             __END__
1029              
1030             =pod
1031              
1032             =encoding UTF-8
1033              
1034             =head1 NAME
1035              
1036             Perinci::Access::Schemeless - Base class for Perinci::Access::Perl
1037              
1038             =head1 VERSION
1039              
1040             This document describes version 0.892 of Perinci::Access::Schemeless (from Perl distribution Perinci-Access-Perl), released on 2020-03-04.
1041              
1042             =head1 DESCRIPTION
1043              
1044             This class is the base class for L<Perinci::Access::Perl>, and by default acts
1045             like Perinci::Access::Perl (e.g. given uri C</Foo/Bar/baz> it will refer to
1046             function C<baz> in Perl package C<Foo::Bar>; it also looks for Rinci metadata in
1047             C<%SPEC> package variables by default). But this class is designed to be
1048             flexible: you can override aspects of it so it can map uri to different Perl
1049             packages (e.g. using option like C<package_prefix>), you can retrieve Rinci
1050             metadata from a database or whatever, etc.
1051              
1052             Supported features:
1053              
1054             =over
1055              
1056             =item * Basic Riap actions
1057              
1058             These include C<info>, C<actions>, C<meta>, C<list>, and C<call> actions.
1059              
1060             =item * Transaction/undo
1061              
1062             According to L<Rinci::Transaction>.
1063              
1064             =item * Function wrapping
1065              
1066             Wrapping is used to convert argument passing style, produce result envelope, add
1067             argument validation, as well as numerous other functionalities. See
1068             L<Perinci::Sub::Wrapper> for more details on wrapping. The default behavior will
1069             call wrapped functions.
1070              
1071             =item * Custom location of metadata
1072              
1073             By default, metadata are assumed to be stored embedded in Perl source code in
1074             C<%SPEC> package variables (with keys matching function names, C<$variable>
1075             names, or C<:package> for the package metadata itself).
1076              
1077             You can override C<get_meta()> to provide custom behavior. For example, you can
1078             store metadata in separate file or database.
1079              
1080             =item * Custom code entity tree
1081              
1082             By default, tree are formed by traversing Perl packages and their contents, for
1083             example if a C<list> action is requested on uri C</Foo/Bar/> then the contents
1084             of package C<Foo::Bar> and its subpackages will be traversed for the entities.
1085              
1086             You can override C<action_list()> to provide custom behavior. For example, you
1087             can lookup from the database.
1088              
1089             =item * Progress indicator
1090              
1091             Functions can express that they do progress updating through the C<features>
1092             property in its metadata:
1093              
1094             features => {
1095             progress => 1,
1096             ...
1097             }
1098              
1099             For these functions, this class will pass a special argument C<-progress>
1100             containing L<Progress::Any> object. Functions can update progress using this
1101             object.
1102              
1103             =back
1104              
1105             =head2 How request is processed
1106              
1107             User calls C<< $pa->request($action => $uri, \%extras) >>. Internally, the
1108             method creates a hash C<$req> which contains Riap request keys as well as
1109             internal information about the Riap request (the latter will be prefixed with
1110             dash C<->). Initially it will contain C<action> and C<uri> and the C<%extras>
1111             keys from the request() arguments sent by the user.
1112              
1113             Internal C<_parse_uri()> method will be called to parse C<uri> into C<-uri_dir>
1114             (the "dir" part), C<-uri_leaf> (the "basename" part), and C<-perl_package>.
1115             Forbidden or invalid paths will cause this method to return an enveloped error
1116             response and the request to stop. For example, if C<uri> is C</Foo/Bar/> then
1117             C<-uri_dir> is C</Foo/Bar/> and C<-uri_leaf> is an empty string. If C<uri> is
1118             C</Foo/Bar/baz> then C<-uri_dir> is C</Foo/Bar/> while C<-uri_leaf> is C<baz>.
1119             C<-uri_dir> will be used for the C<list> action. In both cases, C<-perl_package>
1120             will be set to C<Foo::Bar>.
1121              
1122             The code entity type is then determined currently using a few simple heuristic
1123             rules: if C<-uri_leaf> is empty string, type is C<package>. If C<-uri_leaf>
1124             begins with C<[$%@]>, type is C<variable>. Otherwise, type is C<function>.
1125             C<-type> will be set.
1126              
1127             After this, the appropriate C<action_ACTION()> method will be called. For
1128             example if action is C<meta> then C<action_meta()> method will be called, with
1129             C<$req> as the argument. This will in turn, depending on the action, either call
1130             C<get_meta()> (for example if action is C<meta>) or C<get_code()> (for example
1131             if action is C<call>), also with C<$req> as the argument. C<get_meta()> and
1132             C<get_code()> should return nothing on success, and set either C<-meta> (a
1133             defhash containing Rinci metadata) or C<-code> (a coderef), respectively. On
1134             error, they must return an enveloped error response.
1135              
1136             C<get_meta()> or C<get_code()> might call C<_load_module()> to load Perl modules
1137             if the C<load> attribute is set to true.
1138              
1139             =for Pod::Coverage ^(actionmeta_.+|action_.+|get_(meta|code))$
1140              
1141             =head1 ADDED RESULT METADATA
1142              
1143             This class might add the following property/attribute in result metadata:
1144              
1145             =head2 x.hint.result_binary => bool
1146              
1147             If result's schema type is C<buf>, then this class will set this attribute to
1148             true, to give hints to result formatters.
1149              
1150             =head1 METHODS
1151              
1152             =head2 PKG->new(%attrs) => OBJ
1153              
1154             Instantiate object. Known attributes:
1155              
1156             =over 4
1157              
1158             =item * load => BOOL (default: 1)
1159              
1160             Whether to load Perl modules that are requested.
1161              
1162             =item * after_load => CODE
1163              
1164             If set, code will be executed the first time Perl module is successfully loaded.
1165              
1166             =item * wrap => BOOL (default: 1)
1167              
1168             If set to false, then wil use original subroutine and metadata instead of
1169             wrapped ones, for example if you are very concerned about performance (do not
1170             want to add another eval {} and subroutine call introduced by wrapping) or do
1171             not need the functionality provided by the wrapper (e.g. your function already
1172             validates its arguments, accepts arguments as hash, and returns enveloped
1173             result).
1174              
1175             Wrapping is implemented inside C<get_code()>.
1176              
1177             =item * set_function_properties => HASH
1178              
1179             If set, will be passed to L<Perinci::Sub::Wrapper> wrap_sub()'s C<convert>
1180             argument when wrapping subroutines. Some applications of this include: changing
1181             C<default_lang> of metadata.
1182              
1183             This is only relevant if you enable C<wrap>.
1184              
1185             =item * cache_size => INT (default: 100)
1186              
1187             Specify cache size (in number of items), for caching metadata and wrapping
1188             result. Setting this to 0 disables caching.
1189              
1190             Caching is implemented inside C<get_meta()> and C<get_code()> so you might want
1191             to implement your own caching if you override those.
1192              
1193             =item * allow_paths => REGEX|STR|ARRAY
1194              
1195             If defined, only requests with C<uri> matching specified path will be allowed.
1196             Can be a string (e.g. C</spanel/api/>) or regex (e.g. C<< qr{^/[^/]+/api/} >>)
1197             or an array of those.
1198              
1199             =item * deny_paths => REGEX|STR|ARRAY
1200              
1201             If defined, requests with C<uri> matching specified path will be denied. Like
1202             C<allow_paths>, value can be a string (e.g. C</spanel/api/>) or regex (e.g. C<<
1203             qr{^/[^/]+/api/} >>) or an array of those.
1204              
1205             =item * allow_schemes => REGEX|STR|ARRAY
1206              
1207             By default this class does not care about schemes, it only looks at the uri
1208             path. You can use this option to limit allowed schemes.
1209              
1210             =item * deny_schemes => REGEX|STR|ARRAY
1211              
1212             By default this class does not care about schemes, it only looks at the uri
1213             path. You can use this option to specify forbidden schemes.
1214              
1215             =item * use_tx => BOOL (default: 0)
1216              
1217             Whether to allow transaction requests from client. Since this can cause the
1218             server to store transaction/undo data, this must be explicitly allowed.
1219              
1220             You need to install L<Perinci::Tx::Manager> for transaction support (unless you
1221             are using another transaction manager).
1222              
1223             =item * custom_tx_manager => STR|CODE
1224              
1225             Can be set to a string (class name) or a code that is expected to return a
1226             transaction manager class.
1227              
1228             By default, L<Perinci::Tx::Manager> is instantiated and maintained (not
1229             reinstantiated on every request), but if C<custom_tx_manager> is a coderef, it
1230             will be called on each request to get transaction manager. This can be used to
1231             instantiate Perinci::Tx::Manager in a custom way, e.g. specifying per-user
1232             transaction data directory and limits, which needs to be done on a per-request
1233             basis.
1234              
1235             =item * accept_argv => BOOL (default: 1)
1236              
1237             From version 0.64, C<argv> key is accepted by the C<call> action and will be
1238             converted to C<args>. This server-side conversion from C<argv> to <args> can
1239             handle coderefs in C<cmdline_aliases> (and probably other things too) compared
1240             when doing conversion at the client-side.
1241              
1242             This option allows disabling this behavior.
1243              
1244             =back
1245              
1246             =head2 $pa->request($action => $server_url, \%extra) => $res
1247              
1248             Process Riap request and return enveloped result. $server_url will be used as
1249             the Riap request key 'uri', as there is no server in this case.
1250              
1251             =head2 $pa->parse_url($server_url) => HASH
1252              
1253             =head1 HOMEPAGE
1254              
1255             Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Access-Perl>.
1256              
1257             =head1 SOURCE
1258              
1259             Source repository is at L<https://github.com/perlancar/perl-Perinci-Access-Perl>.
1260              
1261             =head1 BUGS
1262              
1263             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Access-Perl>
1264              
1265             When submitting a bug or request, please include a test-file or a
1266             patch to an existing test-file that illustrates the bug or desired
1267             feature.
1268              
1269             =head1 SEE ALSO
1270              
1271             L<Riap>, L<Rinci>
1272              
1273             =head1 AUTHOR
1274              
1275             perlancar <perlancar@cpan.org>
1276              
1277             =head1 COPYRIGHT AND LICENSE
1278              
1279             This software is copyright (c) 2020, 2019, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar@cpan.org.
1280              
1281             This is free software; you can redistribute it and/or modify it under
1282             the same terms as the Perl 5 programming language system itself.
1283              
1284             =cut