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 |