line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# false positive? line 825 |
2
|
|
|
|
|
|
|
## no critic: Modules::RequireFilenameMatchesPackage |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
# line 820, don't know how to turn off this warning? |
5
|
|
|
|
|
|
|
## no critic: ValuesAndExpressions::ProhibitCommaSeparatedStatements |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
# false positive? perlcritic gives line 2333 which is way more than the number of lines of this script |
8
|
|
|
|
|
|
|
## no critic: InputOutput::RequireBriefOpen |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
use 5.010001; |
12
|
2
|
|
|
2
|
|
78991
|
use strict 'subs', 'vars'; |
|
2
|
|
|
|
|
7
|
|
13
|
2
|
|
|
2
|
|
17
|
use warnings; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
45
|
|
14
|
2
|
|
|
2
|
|
8
|
use Log::ger; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
37
|
|
15
|
2
|
|
|
2
|
|
10
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
9
|
|
16
|
|
|
|
|
|
|
use Data::Dmp; |
17
|
2
|
|
|
2
|
|
1195
|
use JSON::MaybeXS (); |
|
2
|
|
|
|
|
3522
|
|
|
2
|
|
|
|
|
90
|
|
18
|
2
|
|
|
2
|
|
12
|
use Module::CoreList::More; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
29
|
|
19
|
2
|
|
|
2
|
|
857
|
use Module::Path::More qw(module_path); |
|
2
|
|
|
|
|
328007
|
|
|
2
|
|
|
|
|
137
|
|
20
|
2
|
|
|
2
|
|
35
|
use Perinci::Sub::Util qw(err); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
164
|
|
21
|
2
|
|
|
2
|
|
24
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
91
|
|
22
|
|
|
|
|
|
|
use Exporter qw(import); |
23
|
2
|
|
|
2
|
|
12
|
our @EXPORT_OK = qw(gen_inline_pericmd_script); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
626
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY |
26
|
|
|
|
|
|
|
our $DATE = '2022-01-16'; # DATE |
27
|
|
|
|
|
|
|
our $DIST = 'Perinci-CmdLine-Inline'; # DIST |
28
|
|
|
|
|
|
|
our $VERSION = '0.554'; # VERSION |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
our %SPEC; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
state $plc = do { |
33
|
|
|
|
|
|
|
require Data::Sah; |
34
|
125
|
|
|
125
|
|
223
|
Data::Sah->new->get_compiler('perl'); |
35
|
2
|
|
|
|
|
1038
|
}; |
36
|
2
|
|
|
|
|
6103
|
$plc; |
37
|
|
|
|
|
|
|
} |
38
|
125
|
|
|
|
|
49784
|
|
39
|
|
|
|
|
|
|
my ($cd, $mod) = @_; |
40
|
|
|
|
|
|
|
return unless $cd->{gen_args}{pack_deps}; |
41
|
|
|
|
|
|
|
return if $cd->{module_srcs}{$mod}; |
42
|
776
|
|
|
776
|
|
2264
|
log_info("Adding source code of module %s ...", $mod); |
43
|
776
|
50
|
|
|
|
2057
|
log_warn("%s is a core module", $mod) if Module::CoreList::More->is_still_core($mod); |
44
|
776
|
50
|
|
|
|
1787
|
my $path = module_path(module => $mod) or die "Can't load module '$mod'"; |
45
|
776
|
|
|
|
|
3273
|
local $/; |
46
|
776
|
50
|
|
|
|
5408
|
open my($fh), "<", $path or die "Can't read file '$path': $!"; |
47
|
776
|
50
|
|
|
|
646051
|
$cd->{module_srcs}{$mod} = <$fh>; |
48
|
776
|
|
|
|
|
259677
|
} |
49
|
776
|
50
|
|
|
|
24274
|
|
50
|
776
|
|
|
|
|
43740
|
no strict 'refs'; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
my $url = shift; |
53
|
|
|
|
|
|
|
|
54
|
2
|
|
|
2
|
|
13
|
$url =~ m!\A(?:pl:)?((?:/[^/]+)+)/([^/]*)\z! |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
5729
|
|
55
|
|
|
|
|
|
|
or return [412, "URL scheme not supported, only local Perl ". |
56
|
64
|
|
|
64
|
|
325
|
"URL currently supported"]; |
57
|
|
|
|
|
|
|
my ($mod_pm, $short_func_name) = ($1, $2); |
58
|
64
|
50
|
|
|
|
924
|
$mod_pm =~ s!\A/!!; |
59
|
|
|
|
|
|
|
(my $mod = $mod_pm) =~ s!/!::!g; |
60
|
|
|
|
|
|
|
$mod_pm .= ".pm"; |
61
|
64
|
|
|
|
|
523
|
require $mod_pm; |
62
|
64
|
|
|
|
|
696
|
my $meta = ${"$mod\::SPEC"}{length $short_func_name ? $short_func_name : ':package'}; |
63
|
64
|
|
|
|
|
383
|
$meta //= {v=>1.1} if !length $short_func_name; # provide a default empty package metadata |
64
|
64
|
|
|
|
|
226
|
return [412, "Can't find meta for URL '$url'"] unless $meta; |
65
|
64
|
|
|
|
|
347
|
if (length $short_func_name) { |
66
|
64
|
100
|
|
|
|
473
|
defined &{"$mod\::$short_func_name"} |
|
64
|
|
|
|
|
1168
|
|
67
|
64
|
100
|
50
|
|
|
720
|
or return [412, "Can't find function '$short_func_name' for URL '$url'"]; |
68
|
64
|
50
|
|
|
|
407
|
} |
69
|
64
|
100
|
|
|
|
248
|
return [200, "OK", $meta, { |
70
|
55
|
50
|
|
|
|
82
|
'func.module' => $mod, |
|
55
|
|
|
|
|
519
|
|
71
|
|
|
|
|
|
|
'func.module_version' => ${"$mod\::VERSION"}, |
72
|
|
|
|
|
|
|
'func.short_func_name' => $short_func_name, |
73
|
|
|
|
|
|
|
'func.func_name' => "$mod\::$short_func_name", |
74
|
|
|
|
|
|
|
}]; |
75
|
64
|
|
|
|
|
177
|
} |
|
64
|
|
|
|
|
1329
|
|
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
my ($cd) = @_; |
78
|
|
|
|
|
|
|
my @l2; |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
return "" unless $cd->{gen_args}{read_env}; |
81
|
|
|
|
|
|
|
|
82
|
48
|
|
|
48
|
|
127
|
_pack_module($cd, "Complete::Bash"); |
83
|
48
|
|
|
|
|
90
|
_pack_module($cd, "Log::ger"); # required by Complete::Bash |
84
|
|
|
|
|
|
|
push @l2, "{\n"; |
85
|
48
|
100
|
|
|
|
374
|
push @l2, ' last unless $_pci_r->{read_env};', "\n"; |
86
|
|
|
|
|
|
|
push @l2, ' my $env = $ENV{', dmp($cd->{gen_args}{env_name}), '};', "\n"; |
87
|
4
|
|
|
|
|
14
|
push @l2, ' last unless defined $env;', "\n"; |
88
|
4
|
|
|
|
|
23
|
push @l2, ' require Complete::Bash;', "\n"; |
89
|
4
|
|
|
|
|
16
|
push @l2, ' my ($words, undef) = @{ Complete::Bash::parse_cmdline($env, 0) };', "\n"; |
90
|
4
|
|
|
|
|
17
|
push @l2, ' unshift @ARGV, @$words;', "\n"; |
91
|
4
|
|
|
|
|
17
|
push @l2, "}\n"; |
92
|
4
|
|
|
|
|
145
|
|
93
|
4
|
|
|
|
|
12
|
join("", @l2); |
94
|
4
|
|
|
|
|
10
|
} |
95
|
4
|
|
|
|
|
23
|
|
96
|
4
|
|
|
|
|
10
|
my ($cd) = @_; |
97
|
|
|
|
|
|
|
|
98
|
4
|
|
|
|
|
30
|
_pack_module($cd, 'Log::ger'); |
99
|
|
|
|
|
|
|
_pack_module($cd, 'Log::ger::Output'); |
100
|
|
|
|
|
|
|
_pack_module($cd, 'Log::ger::Output::Composite'); |
101
|
|
|
|
|
|
|
_pack_module($cd, 'Log::ger::Output::Screen'); |
102
|
1
|
|
|
1
|
|
7
|
_pack_module($cd, 'Log::ger::Output::SimpleFile'); |
103
|
|
|
|
|
|
|
_pack_module($cd, "Data::Dmp"); # required by Log::ger::Output::Composite |
104
|
1
|
|
|
|
|
7
|
_pack_module($cd, 'Log::ger::Util'); |
105
|
1
|
|
|
|
|
7
|
|
106
|
1
|
|
|
|
|
5
|
my @l; |
107
|
1
|
|
|
|
|
7
|
|
108
|
1
|
|
|
|
|
7
|
push @l, "### begin code_before_enable_logging\n"; |
109
|
1
|
|
|
|
|
9
|
push @l, $cd->{gen_args}{code_before_enable_logging}, "\n" if defined $cd->{gen_args}{code_before_enable_logging}; |
110
|
1
|
|
|
|
|
16
|
push @l, "### end code_before_enable_logging\n"; |
111
|
|
|
|
|
|
|
|
112
|
1
|
|
|
|
|
6
|
push @l, "### enable logging\n"; |
113
|
|
|
|
|
|
|
push @l, '$_pci_log_outputs->{Screen} = { conf => { colorize_tags => 1, formatter => sub { '.dmp("$cd->{script_name}: ").' . $_[0] } } };', "\n"; |
114
|
1
|
|
|
|
|
9
|
|
115
|
1
|
50
|
|
|
|
7
|
push @l, "#### begin code_add_extra_log_outputs\n"; |
116
|
1
|
|
|
|
|
5
|
push @l, $cd->{gen_args}{code_add_extra_log_outputs}, "\n" if defined $cd->{gen_args}{code_add_extra_log_outputs}; |
117
|
|
|
|
|
|
|
push @l, "#### end code_add_extra_log_outputs\n"; |
118
|
1
|
|
|
|
|
2
|
|
119
|
1
|
|
|
|
|
7
|
push @l, 'require Log::ger::Output; Log::ger::Output->set("Composite", outputs => $_pci_log_outputs);', "\n"; |
120
|
|
|
|
|
|
|
push @l, 'require Log::ger; Log::ger->import;', "\n"; |
121
|
1
|
|
|
|
|
36
|
push @l, "\n"; |
122
|
1
|
50
|
|
|
|
4
|
|
123
|
1
|
|
|
|
|
3
|
push @l, "### begin code_after_enable_logging\n"; |
124
|
|
|
|
|
|
|
push @l, $cd->{gen_args}{code_after_enable_logging}, "\n" if defined $cd->{gen_args}{code_after_enable_logging}; |
125
|
1
|
|
|
|
|
11
|
push @l, "### end code_after_enable_logging\n"; |
126
|
1
|
|
|
|
|
4
|
|
127
|
1
|
|
|
|
|
3
|
join("", @l); |
128
|
|
|
|
|
|
|
} |
129
|
1
|
|
|
|
|
2
|
|
130
|
1
|
50
|
|
|
|
38
|
my ($cd) = @_; |
131
|
1
|
|
|
|
|
6
|
my @l2; |
132
|
|
|
|
|
|
|
|
133
|
1
|
|
|
|
|
9
|
return "" unless $cd->{gen_args}{read_config}; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
push @l2, 'if ($_pci_r->{read_config}) {', "\n"; |
136
|
|
|
|
|
|
|
|
137
|
48
|
|
|
48
|
|
162
|
# TOOO: these are manual selection and will be replaced with a recursive |
138
|
48
|
|
|
|
|
87
|
# tracer |
139
|
|
|
|
|
|
|
|
140
|
48
|
100
|
|
|
|
233
|
_pack_module($cd, "Perinci::CmdLine::Util::Config"); |
141
|
|
|
|
|
|
|
_pack_module($cd, "Log::ger"); # required by Perinci::CmdLine::Util::Config |
142
|
12
|
|
|
|
|
43
|
_pack_module($cd, "Config::IOD::Reader"); # required by Perinci::CmdLine::Util::Config |
143
|
|
|
|
|
|
|
_pack_module($cd, "Config::IOD::Base"); # required by Config::IOD::Reader |
144
|
|
|
|
|
|
|
_pack_module($cd, "Data::Sah::Normalize"); # required by Perinci::CmdLine::Util::Config |
145
|
|
|
|
|
|
|
_pack_module($cd, "Data::Sah::Resolve"); # required by Perinci::CmdLine::Util::Config |
146
|
|
|
|
|
|
|
|
147
|
12
|
|
|
|
|
35
|
# required by Data::Sah::Resolve |
148
|
12
|
|
|
|
|
75
|
_pack_module($cd, "Data::Sah::Type::all"); |
149
|
12
|
|
|
|
|
66
|
_pack_module($cd, "Data::Sah::Type::any"); |
150
|
12
|
|
|
|
|
60
|
_pack_module($cd, "Data::Sah::Type::array"); |
151
|
12
|
|
|
|
|
61
|
_pack_module($cd, "Data::Sah::Type::bool"); |
152
|
12
|
|
|
|
|
57
|
_pack_module($cd, "Data::Sah::Type::buf"); |
153
|
|
|
|
|
|
|
_pack_module($cd, "Data::Sah::Type::cistr"); |
154
|
|
|
|
|
|
|
_pack_module($cd, "Data::Sah::Type::code"); |
155
|
12
|
|
|
|
|
82
|
_pack_module($cd, "Data::Sah::Type::date"); |
156
|
12
|
|
|
|
|
58
|
_pack_module($cd, "Data::Sah::Type::datenotime"); |
157
|
12
|
|
|
|
|
57
|
_pack_module($cd, "Data::Sah::Type::datetime"); |
158
|
12
|
|
|
|
|
108
|
_pack_module($cd, "Data::Sah::Type::duration"); |
159
|
12
|
|
|
|
|
76
|
_pack_module($cd, "Data::Sah::Type::float"); |
160
|
12
|
|
|
|
|
59
|
_pack_module($cd, "Data::Sah::Type::hash"); |
161
|
12
|
|
|
|
|
84
|
_pack_module($cd, "Data::Sah::Type::int"); |
162
|
12
|
|
|
|
|
106
|
_pack_module($cd, "Data::Sah::Type::num"); |
163
|
12
|
|
|
|
|
112
|
_pack_module($cd, "Data::Sah::Type::obj"); |
164
|
12
|
|
|
|
|
61
|
_pack_module($cd, "Data::Sah::Type::re"); |
165
|
12
|
|
|
|
|
68
|
_pack_module($cd, "Data::Sah::Type::str"); |
166
|
12
|
|
|
|
|
68
|
_pack_module($cd, "Data::Sah::Type::undef"); |
167
|
12
|
|
|
|
|
80
|
_pack_module($cd, "Data::Sah::Util::Role"); # required by Data::Sah::Type::* |
168
|
12
|
|
|
|
|
61
|
_pack_module($cd, "Role::Tiny"); # required by Data::Sah::Type::* |
169
|
12
|
|
|
|
|
72
|
_pack_module($cd, "Role::Tiny::With"); # required by Data::Sah::Type::* |
170
|
12
|
|
|
|
|
75
|
_pack_module($cd, "Data::Sah::Type::BaseType"); # required by Data::Sah::Type::* |
171
|
12
|
|
|
|
|
85
|
_pack_module($cd, "Data::Sah::Type::Comparable"); # required by Data::Sah::Type::* |
172
|
12
|
|
|
|
|
73
|
_pack_module($cd, "Data::Sah::Type::HasElems"); # required by Data::Sah::Type::* |
173
|
12
|
|
|
|
|
81
|
|
174
|
12
|
|
|
|
|
74
|
_pack_module($cd, "Perinci::Sub::Normalize"); # required by Perinci::CmdLine::Util::Config |
175
|
12
|
|
|
|
|
76
|
_pack_module($cd, "Sah::Schema::rinci::function_meta"); # required by Perinci::Sub::Normalize |
176
|
12
|
|
|
|
|
97
|
push @l2, 'log_trace("Reading config file(s) ...");', "\n" if $cd->{gen_args}{log}; |
177
|
12
|
|
|
|
|
61
|
push @l2, ' require Perinci::CmdLine::Util::Config;', "\n"; |
178
|
12
|
|
|
|
|
67
|
push @l2, "\n"; |
179
|
12
|
|
|
|
|
59
|
push @l2, ' my $res = Perinci::CmdLine::Util::Config::read_config(', "\n"; |
180
|
|
|
|
|
|
|
push @l2, ' config_paths => $_pci_r->{config_paths},', "\n"; |
181
|
12
|
|
|
|
|
68
|
push @l2, ' config_filename => ', dmp($cd->{gen_args}{config_filename}), ",\n"; |
182
|
12
|
|
|
|
|
80
|
push @l2, ' config_dirs => ', dmp($cd->{gen_args}{config_dirs}), ' // ["$ENV{HOME}/.config", $ENV{HOME}, "/etc"],', "\n"; |
183
|
12
|
50
|
|
|
|
83
|
push @l2, ' program_name => ', dmp($cd->{script_name}), ",\n"; |
184
|
12
|
|
|
|
|
58
|
push @l2, ' );', "\n"; |
185
|
12
|
|
|
|
|
38
|
push @l2, ' _pci_err($res) unless $res->[0] == 200;', "\n"; |
186
|
12
|
|
|
|
|
34
|
push @l2, ' $_pci_r->{config} = $res->[2];', "\n"; |
187
|
12
|
|
|
|
|
33
|
push @l2, ' $_pci_r->{read_config_files} = $res->[3]{"func.read_files"};', "\n"; |
188
|
12
|
|
|
|
|
58
|
push @l2, ' $_pci_r->{_config_section_read_order} = $res->[3]{"func.section_read_order"}; # we currently dont want to publish this request key', "\n"; |
189
|
12
|
|
|
|
|
845
|
push @l2, "\n"; |
190
|
12
|
|
|
|
|
988
|
push @l2, ' $res = Perinci::CmdLine::Util::Config::get_args_from_config(', "\n"; |
191
|
12
|
|
|
|
|
334
|
push @l2, ' r => $_pci_r,', "\n"; |
192
|
12
|
|
|
|
|
48
|
push @l2, ' config => $_pci_r->{config},', "\n"; |
193
|
12
|
|
|
|
|
59
|
push @l2, ' args => \%_pci_args,', "\n"; |
194
|
12
|
|
|
|
|
30
|
push @l2, ' program_name => ', dmp($cd->{script_name}), ",\n"; |
195
|
12
|
|
|
|
|
80
|
push @l2, ' subcommand_name => $_pci_r->{subcommand_name},', "\n"; |
196
|
12
|
|
|
|
|
37
|
push @l2, ' config_profile => $_pci_r->{config_profile},', "\n"; |
197
|
12
|
|
|
|
|
80
|
push @l2, ' common_opts => {},', "\n"; # XXX so currently we can't set e.g. format or |
198
|
12
|
|
|
|
|
49
|
push @l2, ' meta => $_pci_metas->{ $_pci_r->{subcommand_name} },', "\n"; |
199
|
12
|
|
|
|
|
40
|
push @l2, ' meta_is_normalized => 1,', "\n"; |
200
|
12
|
|
|
|
|
56
|
push @l2, ' );', "\n"; |
201
|
12
|
|
|
|
|
56
|
push @l2, ' die $res unless $res->[0] == 200;', "\n"; |
202
|
12
|
|
|
|
|
343
|
push @l2, ' my $found = $res->[3]{"func.found"};', "\n"; |
203
|
12
|
|
|
|
|
39
|
push @l2, ' if (defined($_pci_r->{config_profile}) && !$found && defined($_pci_r->{read_config_files}) && @{$_pci_r->{read_config_files}} && !$_pci_r->{ignore_missing_config_profile_section}) {', "\n"; |
204
|
12
|
|
|
|
|
28
|
push @l2, ' _pci_err([412, "Profile \'$_pci_r->{config_profile}\' not found in configuration file"]);', "\n"; |
205
|
12
|
|
|
|
|
33
|
push @l2, ' }', "\n"; |
206
|
12
|
|
|
|
|
76
|
push @l2, '}', "\n"; # if read_config |
207
|
12
|
|
|
|
|
77
|
|
208
|
12
|
|
|
|
|
82
|
join ("", @l2); |
209
|
12
|
|
|
|
|
86
|
} |
210
|
12
|
|
|
|
|
110
|
|
211
|
12
|
|
|
|
|
119
|
my ($cd) = @_; |
212
|
12
|
|
|
|
|
115
|
|
213
|
12
|
|
|
|
|
82
|
my @l2; |
214
|
|
|
|
|
|
|
push @l2, ' my ($args) = @_;', "\n"; |
215
|
12
|
|
|
|
|
182
|
push @l2, ' my $sc_name = $_pci_r->{subcommand_name};', "\n"; |
216
|
|
|
|
|
|
|
my $i = -1; |
217
|
|
|
|
|
|
|
for my $sc_name (sort keys %{$cd->{metas}}) { |
218
|
|
|
|
|
|
|
$i++; |
219
|
48
|
|
|
48
|
|
212
|
my $meta = $cd->{metas}{$sc_name}; |
220
|
|
|
|
|
|
|
my $args_prop = $meta->{args} // {}; |
221
|
48
|
|
|
|
|
98
|
push @l2, ' '.($i ? "elsif":"if").' ($sc_name eq '.dmp($sc_name).") {\n"; |
222
|
48
|
|
|
|
|
347
|
push @l2, " FILL_FROM_POS: {\n"; |
223
|
48
|
|
|
|
|
456
|
push @l2, " 1;\n"; # to avoid syntax error when there is 0 args |
224
|
48
|
|
|
|
|
206
|
for my $arg (sort { |
225
|
48
|
|
|
|
|
133
|
($args_prop->{$b}{pos} // 9999) <=> |
|
48
|
|
|
|
|
363
|
|
226
|
53
|
|
|
|
|
139
|
($args_prop->{$a}{pos} // 9999) |
227
|
53
|
|
|
|
|
287
|
} keys %$args_prop) { |
228
|
53
|
|
100
|
|
|
404
|
my $arg_spec = $args_prop->{$arg}; |
229
|
53
|
100
|
|
|
|
658
|
my $arg_opts = $cd->{ggl_res}{$sc_name}[3]{'func.opts_by_arg'}{$arg}; |
230
|
53
|
|
|
|
|
3542
|
next unless defined $arg_spec->{pos}; |
231
|
53
|
|
|
|
|
177
|
push @l2, ' if (@ARGV > '.$arg_spec->{pos}.') {'; |
232
|
53
|
|
|
|
|
344
|
push @l2, ' if (exists $args->{"'.$arg.'"}) {'; |
233
|
|
|
|
|
|
|
push @l2, ' return [400, "You specified '.$arg_opts->[0].' but also argument #'.$arg_spec->{pos}.'"];'; |
234
|
89
|
|
100
|
|
|
514
|
push @l2, " } else {"; |
|
|
|
100
|
|
|
|
|
235
|
|
|
|
|
|
|
if ($arg_spec->{slurpy} // $arg_spec->{greedy}) { |
236
|
83
|
|
|
|
|
193
|
push @l2, ' $args->{"'.$arg.'"} = [splice(@ARGV, '.$arg_spec->{pos}.')];'; |
237
|
83
|
|
|
|
|
290
|
} else { |
238
|
83
|
100
|
|
|
|
276
|
push @l2, ' $args->{"'.$arg.'"} = delete($ARGV['.$arg_spec->{pos}.']);'; |
239
|
67
|
|
|
|
|
249
|
} |
240
|
67
|
|
|
|
|
274
|
push @l2, " }"; |
241
|
67
|
|
|
|
|
253
|
push @l2, " }\n"; |
242
|
67
|
|
|
|
|
226
|
} |
243
|
67
|
100
|
66
|
|
|
393
|
push @l2, " }\n"; |
244
|
5
|
|
|
|
|
33
|
push @l2, ' my @check_argv = @ARGV;', "\n"; |
245
|
|
|
|
|
|
|
|
246
|
62
|
|
|
|
|
197
|
push @l2, ' # fill from cmdline_src', "\n"; |
247
|
|
|
|
|
|
|
{ |
248
|
67
|
|
|
|
|
173
|
my $stdin_seen; |
249
|
67
|
|
|
|
|
254
|
my $req_gen_iter; |
250
|
|
|
|
|
|
|
for my $arg (sort { |
251
|
53
|
|
|
|
|
291
|
my $asa = $args_prop->{$a}; |
252
|
53
|
|
|
|
|
341
|
my $asb = $args_prop->{$b}; |
253
|
|
|
|
|
|
|
my $csa = $asa->{cmdline_src} // ''; |
254
|
53
|
|
|
|
|
420
|
my $csb = $asb->{cmdline_src} // ''; |
255
|
|
|
|
|
|
|
# stdin_line is processed before stdin |
256
|
53
|
|
|
|
|
115
|
($csa eq 'stdin_line' ? 1:2) <=> |
|
53
|
|
|
|
|
103
|
|
257
|
|
|
|
|
|
|
($csa eq 'stdin_line' ? 1:2) |
258
|
53
|
|
|
|
|
213
|
|| |
259
|
90
|
|
|
|
|
148
|
($asa->{pos} // 9999) <=> ($asb->{pos} // 9999) |
260
|
90
|
|
|
|
|
134
|
} keys %$args_prop) { |
261
|
90
|
|
50
|
|
|
436
|
my $arg_spec = $args_prop->{$arg}; |
262
|
90
|
|
50
|
|
|
310
|
my $cs = $arg_spec->{cmdline_src}; |
263
|
|
|
|
|
|
|
my $sch = $arg_spec->{schema} // ''; |
264
|
|
|
|
|
|
|
$sch = $sch->[1]{of} if $arg_spec->{stream} && $sch->[0] eq 'array'; |
265
|
|
|
|
|
|
|
my $type = Data::Sah::Util::Type::get_type($sch); |
266
|
|
|
|
|
|
|
next unless $cs; |
267
|
90
|
50
|
100
|
|
|
525
|
if ($cs eq 'stdin_line') { |
|
|
50
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# XXX support stdin_line, cmdline_prompt, is_password (for disabling echo) |
269
|
83
|
|
|
|
|
171
|
return [501, "cmdline_src=stdin_line is not yet supported"]; |
270
|
83
|
|
|
|
|
243
|
} elsif ($cs eq 'stdin_or_file') { |
271
|
83
|
|
50
|
|
|
288
|
return [400, "arg $arg: More than one cmdline_src=/stdin/ is found (arg=$stdin_seen)"] |
272
|
83
|
100
|
66
|
|
|
348
|
if defined $stdin_seen; |
273
|
83
|
|
|
|
|
193
|
$stdin_seen = $arg; |
274
|
83
|
100
|
|
|
|
859
|
# XXX support - to mean stdin |
275
|
4
|
50
|
|
|
|
56
|
push @l2, ' { my $fh;'; |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
276
|
|
|
|
|
|
|
push @l2, ' if (exists $args->{"'.$arg.'"}) {'; |
277
|
0
|
|
|
|
|
0
|
push @l2, ' open $fh, "<", $args->{"'.$arg.'"} or _pci_err([500,"Cannot open file \'".$args->{"'.$arg.'"}."\': $!"]);'; |
278
|
|
|
|
|
|
|
push @l2, ' } else { $fh = \*STDIN }'; |
279
|
0
|
0
|
|
|
|
0
|
if ($arg_spec->{stream}) { |
280
|
|
|
|
|
|
|
$req_gen_iter++; |
281
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter($fh, "'.$type.'", "'.$arg.'")'; |
282
|
|
|
|
|
|
|
} elsif ($type eq 'array') { |
283
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [<$fh>] }'; |
284
|
0
|
|
|
|
|
0
|
} else { |
285
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<$fh> }'; |
286
|
0
|
|
|
|
|
0
|
} |
287
|
0
|
0
|
|
|
|
0
|
push @l2, " }\n"; |
|
|
0
|
|
|
|
|
|
288
|
0
|
|
|
|
|
0
|
} elsif ($cs eq 'file') { |
289
|
0
|
|
|
|
|
0
|
# XXX support - to mean stdin |
290
|
|
|
|
|
|
|
push @l2, ' if (!(exists $args->{"'.$arg.'"}) && '.($arg_spec->{req} ? 1:0).') { _pci_err([500,"Please specify filename for argument \''.$arg.'\'"]) }'; |
291
|
0
|
|
|
|
|
0
|
push @l2, ' if (exists $args->{"'.$arg.'"}) {'; |
292
|
|
|
|
|
|
|
push @l2, ' open my($fh), "<", $args->{"'.$arg.'"} or _pci_err([500,"Cannot open file \'".$_pci_args{"'.$arg.'"}."\': $!"]);'; |
293
|
0
|
|
|
|
|
0
|
if ($arg_spec->{stream}) { |
294
|
|
|
|
|
|
|
$req_gen_iter++; |
295
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter($fh, "'.$type.'", "'.$arg.'")'; |
296
|
|
|
|
|
|
|
} elsif ($type eq 'array') { |
297
|
|
|
|
|
|
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [<$fh>] }'; |
298
|
0
|
0
|
|
|
|
0
|
} else { |
299
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<$fh> }'; |
300
|
0
|
|
|
|
|
0
|
} |
301
|
0
|
0
|
|
|
|
0
|
push @l2, " }\n"; |
|
|
0
|
|
|
|
|
|
302
|
0
|
|
|
|
|
0
|
} elsif ($cs eq 'stdin') { |
303
|
0
|
|
|
|
|
0
|
return [400, "arg $arg: More than one cmdline_src=/stdin/ is found (arg=$stdin_seen)"] |
304
|
|
|
|
|
|
|
if defined $stdin_seen; |
305
|
0
|
|
|
|
|
0
|
$stdin_seen = $arg; |
306
|
|
|
|
|
|
|
push @l2, ' unless (exists $args->{"'.$arg.'"}) {'; |
307
|
0
|
|
|
|
|
0
|
if ($arg_spec->{stream}) { |
308
|
|
|
|
|
|
|
$req_gen_iter++; |
309
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter(\*STDIN, "'.$type.'", "'.$arg.'")'; |
310
|
|
|
|
|
|
|
} elsif ($type eq 'array') { |
311
|
0
|
0
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [<STDIN>] }'; |
312
|
|
|
|
|
|
|
} else { |
313
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<STDIN> }'; |
314
|
0
|
|
|
|
|
0
|
} |
315
|
0
|
0
|
|
|
|
0
|
push @l2, " }\n"; |
|
|
0
|
|
|
|
|
|
316
|
0
|
|
|
|
|
0
|
} elsif ($cs eq 'stdin_or_files') { |
317
|
0
|
|
|
|
|
0
|
return [400, "arg $arg: More than one cmdline_src=/stdin/ is found (arg=$stdin_seen)"] |
318
|
|
|
|
|
|
|
if defined $stdin_seen; |
319
|
0
|
|
|
|
|
0
|
$stdin_seen = $arg; |
320
|
|
|
|
|
|
|
push @l2, ' unless (exists $args->{"'.$arg.'"}) {'; |
321
|
0
|
|
|
|
|
0
|
push @l2, ' @check_argv = ();'; |
322
|
|
|
|
|
|
|
if ($arg_spec->{stream}) { |
323
|
0
|
|
|
|
|
0
|
$req_gen_iter++; |
324
|
|
|
|
|
|
|
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter(\*ARGV, "'.$type.'", "'.$arg.'")'; |
325
|
4
|
50
|
|
|
|
24
|
} elsif ($type eq 'array') { |
326
|
|
|
|
|
|
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [<>] }'; |
327
|
4
|
|
|
|
|
13
|
} else { |
328
|
4
|
|
|
|
|
32
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<> }'; |
329
|
4
|
|
|
|
|
21
|
} |
330
|
4
|
50
|
|
|
|
16
|
push @l2, " }\n"; |
|
|
0
|
|
|
|
|
|
331
|
4
|
|
|
|
|
10
|
} elsif ($cs eq 'stdin_or_args') { |
332
|
4
|
|
|
|
|
34
|
return [400, "arg $arg: More than one cmdline_src=/stdin/ is found (arg=$stdin_seen)"] |
333
|
|
|
|
|
|
|
if defined $stdin_seen; |
334
|
0
|
|
|
|
|
0
|
$stdin_seen = $arg; |
335
|
|
|
|
|
|
|
push @l2, ' unless (exists $args->{"'.$arg.'"}) {'; |
336
|
0
|
|
|
|
|
0
|
push @l2, ' @check_argv = ();'; |
337
|
|
|
|
|
|
|
if ($arg_spec->{stream}) { |
338
|
4
|
|
|
|
|
29
|
$req_gen_iter++; |
339
|
|
|
|
|
|
|
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter(\*STDIN, "'.$type.'", "'.$arg.'")'; |
340
|
0
|
0
|
|
|
|
0
|
} elsif ($type eq 'array') { |
341
|
|
|
|
|
|
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [map {chomp;$_} <>] }'; |
342
|
0
|
|
|
|
|
0
|
} else { |
343
|
0
|
|
|
|
|
0
|
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<> }'; |
344
|
0
|
|
|
|
|
0
|
} |
345
|
0
|
0
|
|
|
|
0
|
push @l2, " }\n"; |
|
|
0
|
|
|
|
|
|
346
|
0
|
|
|
|
|
0
|
} else { |
347
|
0
|
|
|
|
|
0
|
return [400, "arg $arg: unknown cmdline_src value '$cs'"]; |
348
|
|
|
|
|
|
|
} |
349
|
0
|
|
|
|
|
0
|
} |
350
|
|
|
|
|
|
|
|
351
|
0
|
|
|
|
|
0
|
unless ($req_gen_iter) { |
352
|
|
|
|
|
|
|
delete $cd->{sub_srcs}{_pci_gen_iter}; |
353
|
0
|
|
|
|
|
0
|
delete $cd->{module_srcs}{'Data::Sah::Util::Type'}; |
354
|
|
|
|
|
|
|
} |
355
|
0
|
|
|
|
|
0
|
} # fill from cmdline_src |
356
|
|
|
|
|
|
|
push @l2, "\n"; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
push @l2, ' # fill defaults from "default" property and check against schema', "\n"; |
359
|
53
|
100
|
|
|
|
205
|
GEN_VALIDATION: |
360
|
49
|
|
|
|
|
144
|
{ |
361
|
49
|
|
|
|
|
153
|
my $has_validation; |
362
|
|
|
|
|
|
|
my @l3; |
363
|
|
|
|
|
|
|
my @modules_for_all_args; |
364
|
53
|
|
|
|
|
279
|
my @req_stmts; |
365
|
|
|
|
|
|
|
for my $arg (sort keys %$args_prop) { |
366
|
53
|
|
|
|
|
419
|
my $arg_spec = $args_prop->{$arg}; |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
# we don't validate streaming input for now |
369
|
53
|
|
|
|
|
119
|
next if $arg_spec->{stream}; |
|
53
|
|
|
|
|
367
|
|
370
|
|
|
|
|
|
|
|
371
|
53
|
|
|
|
|
0
|
my $arg_schema = $arg_spec->{schema}; |
372
|
53
|
|
|
|
|
0
|
my $arg_term = '$args->{"'.$arg.'"}'; |
373
|
53
|
|
|
|
|
501
|
if (defined $arg_spec->{default}) { |
374
|
83
|
|
|
|
|
203
|
push @l3, " $arg_term //= ".dmp($arg_spec->{default}).";\n"; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
83
|
100
|
|
|
|
246
|
if ($arg_schema && $cd->{gen_args}{validate_args}) { |
378
|
|
|
|
|
|
|
$has_validation++; |
379
|
79
|
|
|
|
|
130
|
my $dsah_cd = _dsah_plc->compile( |
380
|
79
|
|
|
|
|
269
|
schema => $arg_schema, |
381
|
79
|
50
|
|
|
|
231
|
schema_is_normalized => 1, |
382
|
0
|
|
|
|
|
0
|
indent_level => 3, |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
data_term => $arg_term, |
385
|
79
|
50
|
33
|
|
|
672
|
err_term => '$_sahv_err', |
386
|
79
|
|
|
|
|
180
|
return_type => 'str', |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
core_or_pp => 1, |
389
|
|
|
|
|
|
|
( whitelist_modules => $cd->{gen_args}{allow_prereq} ) x !!$cd->{gen_args}{allow_prereq}, |
390
|
|
|
|
|
|
|
); |
391
|
|
|
|
|
|
|
die "Incompatible Data::Sah version (cd v=$dsah_cd->{v}, expected 2)" unless $dsah_cd->{v} == 2; |
392
|
|
|
|
|
|
|
# add require statements for modules needed during |
393
|
|
|
|
|
|
|
# validation |
394
|
|
|
|
|
|
|
for my $mod_rec (@{$dsah_cd->{modules}}) { |
395
|
|
|
|
|
|
|
next unless $mod_rec->{phase} eq 'runtime'; |
396
|
|
|
|
|
|
|
next if grep { ($mod_rec->{use_statement} && $_->{use_statement} && $_->{use_statement} eq $mod_rec->{use_statement}) || |
397
|
|
|
|
|
|
|
$_->{name} eq $mod_rec->{name} } @modules_for_all_args; |
398
|
79
|
|
|
|
|
259
|
push @modules_for_all_args, $mod_rec; |
399
|
79
|
50
|
|
|
|
349401
|
if ($mod_rec->{name} =~ /\A(Scalar::Util::Numeric::PP)\z/) { |
400
|
|
|
|
|
|
|
_pack_module($cd, $mod_rec->{name}); |
401
|
|
|
|
|
|
|
} |
402
|
79
|
|
|
|
|
154
|
my $mod_is_core = Module::CoreList::More->is_still_core($mod_rec->{name}); |
|
79
|
|
|
|
|
216
|
|
403
|
185
|
100
|
|
|
|
870
|
log_warn("Validation code requires non-core module '%s'", $mod_rec->{name}) |
404
|
96
|
100
|
|
|
|
244
|
unless $mod_is_core && !$cd->{module_srcs}{$mod_rec->{name}} && |
405
|
82
|
100
|
100
|
|
|
984
|
!($cd->{gen_args}{allow_prereq} && grep { $_ eq $mod_rec->{name} } @{$cd->{gen_args}{allow_prereq}}); |
|
|
|
66
|
|
|
|
|
406
|
46
|
|
|
|
|
142
|
# skip modules that we already require at the |
407
|
46
|
100
|
|
|
|
239
|
# beginning of script |
408
|
12
|
|
|
|
|
69
|
next if exists $cd->{req_modules}{$mod_rec->{name}}; |
409
|
|
|
|
|
|
|
push @req_stmts, _dsah_plc->stmt_require_module($mod_rec); |
410
|
46
|
|
|
|
|
327
|
} |
411
|
|
|
|
|
|
|
push @l3, " if (exists $arg_term) {\n"; |
412
|
|
|
|
|
|
|
push @l3, " \$_sahv_dpath = [];\n"; |
413
|
46
|
50
|
66
|
|
|
44553
|
push @l3, $dsah_cd->{result}, "\n"; |
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
414
|
|
|
|
|
|
|
push @l3, " ; if (\$_sahv_err) { return [400, \"Argument validation failed: \$_sahv_err\"] }\n"; |
415
|
|
|
|
|
|
|
push @l3, " } # if date arg exists\n"; |
416
|
46
|
50
|
|
|
|
401
|
} |
417
|
46
|
|
|
|
|
170
|
} |
418
|
|
|
|
|
|
|
push @l3, "\n"; |
419
|
79
|
|
|
|
|
455
|
|
420
|
79
|
|
|
|
|
147
|
if ($has_validation) { |
421
|
79
|
|
|
|
|
251
|
push @l2, map {" $_\n"} @req_stmts; |
422
|
79
|
|
|
|
|
191
|
push @l2, " my \$_sahv_dpath;\n"; |
423
|
79
|
|
|
|
|
1385
|
push @l2, " my \$_sahv_err;\n"; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
53
|
|
|
|
|
247
|
push @l2, @l3; |
427
|
|
|
|
|
|
|
} # GEN_VALIDATION |
428
|
53
|
100
|
|
|
|
202
|
|
429
|
29
|
|
|
|
|
90
|
push @l2, ' # check required args', "\n"; |
|
46
|
|
|
|
|
256
|
|
430
|
29
|
|
|
|
|
128
|
for my $arg (sort keys %$args_prop) { |
431
|
29
|
|
|
|
|
165
|
my $arg_spec = $args_prop->{$arg}; |
432
|
|
|
|
|
|
|
if ($arg_spec->{req}) { |
433
|
|
|
|
|
|
|
push @l2, ' return [400, "Missing required argument: '.$arg.'"] unless exists $args->{"'.$arg.'"};', "\n"; |
434
|
53
|
|
|
|
|
265
|
} |
435
|
|
|
|
|
|
|
if ($arg_spec->{schema}[1]{req}) { |
436
|
|
|
|
|
|
|
push @l2, ' return [400, "Missing required value for argument: '.$arg.'"] if exists($args->{"'.$arg.'"}) && !defined($args->{"'.$arg.'"});', "\n"; |
437
|
53
|
|
|
|
|
336
|
} |
438
|
53
|
|
|
|
|
337
|
} |
439
|
83
|
|
|
|
|
168
|
|
440
|
83
|
100
|
|
|
|
218
|
push @l2, ' _pci_err([500, "Extraneous command-line argument(s): ".join(", ", @check_argv)]) if @check_argv;', "\n"; |
441
|
14
|
|
|
|
|
124
|
push @l2, ' [200];', "\n"; |
442
|
|
|
|
|
|
|
push @l2, ' }'; |
443
|
83
|
100
|
|
|
|
296
|
} # for subcommand |
444
|
18
|
|
|
|
|
102
|
push @l2, ' else { _pci_err([500, "Unknown subcommand1: $sc_name"]); }', "\n"; |
445
|
|
|
|
|
|
|
$cd->{module_srcs}{"Local::_pci_check_args"} = "sub _pci_check_args {\n".join('', @l2)."}\n1;\n"; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
53
|
|
|
|
|
346
|
my ($cd, $co) = @_; |
449
|
53
|
|
|
|
|
149
|
|
450
|
53
|
|
|
|
|
290
|
my @l; |
451
|
|
|
|
|
|
|
|
452
|
48
|
|
|
|
|
378
|
my $has_subcommands = $cd->{gen_args}{subcommands}; |
453
|
48
|
|
|
|
|
1219
|
|
454
|
|
|
|
|
|
|
if ($co eq 'help') { |
455
|
|
|
|
|
|
|
if ($has_subcommands) { |
456
|
|
|
|
|
|
|
push @l, 'my $sc_name = $_pci_r->{subcommand_name}; '; |
457
|
408
|
|
|
408
|
|
709
|
push @l, 'my $first_non_opt_arg; for (@ARGV) { next if /^-/; $first_non_opt_arg = $_; last } if (!length $sc_name && defined $first_non_opt_arg) { $sc_name = $first_non_opt_arg } '; |
458
|
|
|
|
|
|
|
push @l, 'if (!length $sc_name) { print $help_msg } '; |
459
|
408
|
|
|
|
|
494
|
for (sort keys %{ $cd->{helps} }) { |
460
|
|
|
|
|
|
|
push @l, 'elsif ($sc_name eq '.dmp($_).') { print '.dmp($cd->{helps}{$_}).' } '; |
461
|
408
|
|
|
|
|
610
|
} |
462
|
|
|
|
|
|
|
push @l, 'else { _pci_err([500, "Unknown subcommand2: $sc_name"]) } '; |
463
|
408
|
100
|
|
|
|
2783
|
push @l, 'exit 0'; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
464
|
48
|
100
|
|
|
|
151
|
} else { |
465
|
9
|
|
|
|
|
61
|
require Perinci::CmdLine::Help; |
466
|
9
|
|
|
|
|
60
|
my $res = Perinci::CmdLine::Help::gen_help( |
467
|
9
|
|
|
|
|
28
|
meta => $cd->{metas}{''}, |
468
|
9
|
|
|
|
|
19
|
meta_is_normalized => 1, |
|
9
|
|
|
|
|
54
|
|
469
|
23
|
|
|
|
|
1300
|
common_opts => $cd->{copts}, |
470
|
|
|
|
|
|
|
program_name => $cd->{script_name}, |
471
|
9
|
|
|
|
|
846
|
); |
472
|
9
|
|
|
|
|
83
|
return [500, "Can't generate help: $res->[0] - $res->[1]"] |
473
|
|
|
|
|
|
|
unless $res->[0] == 200; |
474
|
39
|
|
|
|
|
1466
|
push @l, 'print ', dmp($res->[2]), '; exit 0;'; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
} elsif ($co eq 'version') { |
477
|
|
|
|
|
|
|
no strict 'refs'; |
478
|
|
|
|
|
|
|
my $mod = $cd->{sc_mods}{''}; |
479
|
|
|
|
|
|
|
push @l, "no warnings 'once'; "; |
480
|
39
|
|
|
|
|
3758
|
push @l, "require $mod; " if $mod; |
481
|
39
|
50
|
|
|
|
272626
|
push @l, 'print "', $cd->{script_name} , ' version ", '; |
482
|
|
|
|
|
|
|
if ($cd->{gen_args}{script_version_from_main_version}) { |
483
|
39
|
|
|
|
|
182
|
push @l, "\$main::VERSION // '?'", ", (\$main::DATE ? \" (\$main\::DATE)\" : '')"; |
484
|
|
|
|
|
|
|
} else { |
485
|
|
|
|
|
|
|
push @l, defined($cd->{gen_args}{script_version}) ? "\"$cd->{gen_args}{script_version}\"" : |
486
|
2
|
|
|
2
|
|
16
|
"(\$$mod\::VERSION // '?')", |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
5457
|
|
487
|
48
|
|
|
|
|
172
|
", (\$$mod\::DATE ? \" (\$$mod\::DATE)\" : '')"; |
488
|
48
|
|
|
|
|
176
|
} |
489
|
48
|
50
|
|
|
|
355
|
push @l, ', "\\n"; '; |
490
|
48
|
|
|
|
|
325
|
push @l, 'print " Generated by ', __PACKAGE__ , ' version ', |
491
|
48
|
50
|
|
|
|
204
|
(${__PACKAGE__."::VERSION"} // 'dev'), |
492
|
0
|
|
|
|
|
0
|
(${__PACKAGE__."::DATE"} ? " (".${__PACKAGE__."::DATE"}.")" : ""), |
493
|
|
|
|
|
|
|
'\n"; '; |
494
|
48
|
50
|
|
|
|
633
|
push @l, 'exit 0'; |
495
|
|
|
|
|
|
|
} elsif ($co eq 'log_level') { |
496
|
|
|
|
|
|
|
push @l, 'if ($_[1] eq "trace") { require Log::ger::Util; Log::ger::Util::set_level("trace"); Log::ger::Output::Composite::set_level("trace") } '; |
497
|
|
|
|
|
|
|
push @l, 'if ($_[1] eq "debug") { require Log::ger::Util; Log::ger::Util::set_level("debug"); Log::ger::Output::Composite::set_level("debug") } '; |
498
|
48
|
|
|
|
|
293
|
push @l, 'if ($_[1] eq "info" ) { require Log::ger::Util; Log::ger::Util::set_level("info" ); Log::ger::Output::Composite::set_level("info") } '; |
499
|
|
|
|
|
|
|
push @l, 'if ($_[1] eq "error") { require Log::ger::Util; Log::ger::Util::set_level("warn" ); Log::ger::Output::Composite::set_level("warn") } '; |
500
|
48
|
|
|
|
|
482
|
push @l, 'if ($_[1] eq "fatal") { require Log::ger::Util; Log::ger::Util::set_level("debug"); Log::ger::Output::Composite::set_level("debug") } '; |
501
|
48
|
50
|
50
|
|
|
144
|
push @l, 'if ($_[1] eq "none") { require Log::ger::Util; Log::ger::Util::set_level("off" ); Log::ger::Output::Composite::set_level("off") } '; |
|
48
|
|
|
|
|
384
|
|
|
48
|
|
|
|
|
340
|
|
502
|
|
|
|
|
|
|
push @l, 'if ($_[1] eq "off") { require Log::ger::Util; Log::ger::Util::set_level("off" ); Log::ger::Output::Composite::set_level("off") } '; |
503
|
48
|
|
|
|
|
128
|
push @l, '$_pci_r->{log_level} = $_[1];'; |
504
|
|
|
|
|
|
|
} elsif ($co eq 'trace') { |
505
|
1
|
|
|
|
|
5
|
push @l, 'require Log::ger::Util; Log::ger::Util::set_level("trace"); $_pci_r->{log_level} = "trace";'; |
506
|
1
|
|
|
|
|
3
|
} elsif ($co eq 'debug') { |
507
|
1
|
|
|
|
|
1
|
push @l, 'require Log::ger::Util; Log::ger::Util::set_level("debug"); $_pci_r->{log_level} = "debug";'; |
508
|
1
|
|
|
|
|
9
|
} elsif ($co eq 'verbose') { |
509
|
1
|
|
|
|
|
3
|
push @l, 'require Log::ger::Util; Log::ger::Util::set_level("info" ); $_pci_r->{log_level} = "info" ;'; |
510
|
1
|
|
|
|
|
4
|
} elsif ($co eq 'quiet') { |
511
|
1
|
|
|
|
|
8
|
push @l, 'require Log::ger::Util; Log::ger::Util::set_level("error"); $_pci_r->{log_level} = "error";'; |
512
|
1
|
|
|
|
|
3
|
} elsif ($co eq 'subcommands') { |
513
|
|
|
|
|
|
|
my $scs_text = "Available subcommands:\n"; |
514
|
1
|
|
|
|
|
3
|
for (sort keys %{ $cd->{metas} }) { |
515
|
|
|
|
|
|
|
$scs_text .= " $_\n"; |
516
|
1
|
|
|
|
|
12
|
} |
517
|
|
|
|
|
|
|
push @l, 'print ', dmp($scs_text), '; exit 0'; |
518
|
1
|
|
|
|
|
6
|
} elsif ($co eq 'cmd') { |
519
|
|
|
|
|
|
|
push @l, '$_[2]{subcommand} = [$_[1]]; '; # for Getopt::Long::Subcommand |
520
|
1
|
|
|
|
|
11
|
push @l, '$_pci_r->{subcommand_name} = $_[1];'; |
521
|
|
|
|
|
|
|
} elsif ($co eq 'format') { |
522
|
9
|
|
|
|
|
52
|
push @l, '$_pci_r->{format} = $_[1];'; |
523
|
9
|
|
|
|
|
23
|
} elsif ($co eq 'json') { |
|
9
|
|
|
|
|
53
|
|
524
|
14
|
|
|
|
|
44
|
push @l, '$_pci_r->{format} = (-t STDOUT) ? "json-pretty" : "json"; ## no critic InputOutput::ProhibitInteractiveTest' . "\n"; |
525
|
|
|
|
|
|
|
} elsif ($co eq 'naked_res') { |
526
|
9
|
|
|
|
|
34
|
push @l, '$_pci_r->{naked_res} = 1;'; |
527
|
|
|
|
|
|
|
} elsif ($co eq 'no_naked_res') { |
528
|
18
|
|
|
|
|
67
|
push @l, '$_pci_r->{naked_res} = 0;'; |
529
|
18
|
|
|
|
|
66
|
} elsif ($co eq 'no_config') { |
530
|
|
|
|
|
|
|
push @l, '$_pci_r->{read_config} = 0;'; |
531
|
48
|
|
|
|
|
303
|
} elsif ($co eq 'config_path') { |
532
|
|
|
|
|
|
|
push @l, '$_pci_r->{config_paths} //= []; '; |
533
|
48
|
|
|
|
|
125
|
push @l, 'push @{ $_pci_r->{config_paths} }, $_[1];'; |
534
|
|
|
|
|
|
|
} elsif ($co eq 'config_profile') { |
535
|
48
|
|
|
|
|
130
|
push @l, '$_pci_r->{config_profile} = $_[1];'; |
536
|
|
|
|
|
|
|
} elsif ($co eq 'no_env') { |
537
|
48
|
|
|
|
|
297
|
push @l, '$_pci_r->{read_env} = 0;'; |
538
|
|
|
|
|
|
|
} elsif ($co eq 'page_result') { |
539
|
12
|
|
|
|
|
40
|
push @l, '$_pci_r->{page_result} = 1;'; |
540
|
|
|
|
|
|
|
} else { |
541
|
12
|
|
|
|
|
75
|
die "BUG: Unrecognized common_opt '$co'"; |
542
|
12
|
|
|
|
|
78
|
} |
543
|
|
|
|
|
|
|
join "", @l; |
544
|
12
|
|
|
|
|
30
|
} |
545
|
|
|
|
|
|
|
|
546
|
4
|
|
|
|
|
11
|
my ($cd) = @_; |
547
|
|
|
|
|
|
|
|
548
|
48
|
|
|
|
|
246
|
my @l; |
549
|
|
|
|
|
|
|
|
550
|
0
|
|
|
|
|
0
|
push @l, 'my %mentioned_args;', "\n"; |
551
|
|
|
|
|
|
|
|
552
|
408
|
|
|
|
|
5527
|
_pack_module($cd, "Getopt::Long::EvenLess"); |
553
|
|
|
|
|
|
|
push @l, "require Getopt::Long::EvenLess;\n"; |
554
|
|
|
|
|
|
|
push @l, 'log_trace("Parsing command-line arguments ...");', "\n" if $cd->{gen_args}{log}; |
555
|
|
|
|
|
|
|
|
556
|
48
|
|
|
48
|
|
216
|
if ($cd->{gen_args}{subcommands}) { |
557
|
|
|
|
|
|
|
|
558
|
48
|
|
|
|
|
114
|
_pack_module($cd, "Getopt::Long::Subcommand"); |
559
|
|
|
|
|
|
|
push @l, "require Getopt::Long::Subcommand;\n"; |
560
|
48
|
|
|
|
|
241
|
# we haven't added the Complete::* that Getopt::Long::Subcommand depends on |
561
|
|
|
|
|
|
|
|
562
|
48
|
|
|
|
|
300
|
# generate help message for all subcommands |
563
|
48
|
|
|
|
|
477
|
{ |
564
|
48
|
100
|
|
|
|
362
|
require Perinci::CmdLine::Help; |
565
|
|
|
|
|
|
|
my %helps; # key = subcommand name |
566
|
48
|
100
|
|
|
|
382
|
for my $sc_name (sort keys %{ $cd->{metas} }) { |
567
|
|
|
|
|
|
|
next if $sc_name eq ''; |
568
|
9
|
|
|
|
|
96
|
my $meta = $cd->{metas}{$sc_name}; |
569
|
9
|
|
|
|
|
42
|
my $res = Perinci::CmdLine::Help::gen_help( |
570
|
|
|
|
|
|
|
meta => $meta, |
571
|
|
|
|
|
|
|
common_opts => { map {$_ => $cd->{copts}{$_}} grep { $_ !~ /\A(subcommands|cmd)\z/ } keys %{$cd->{copts}} }, |
572
|
|
|
|
|
|
|
program_name => "$cd->{script_name} $sc_name", |
573
|
|
|
|
|
|
|
); |
574
|
9
|
|
|
|
|
22
|
return [500, "Can't generate help (subcommand='$sc_name'): $res->[0] - $res->[1]"] |
|
9
|
|
|
|
|
57
|
|
575
|
9
|
|
|
|
|
98
|
unless $res->[0] == 200; |
576
|
9
|
|
|
|
|
23
|
$helps{$sc_name} = $res->[2]; |
|
9
|
|
|
|
|
81
|
|
577
|
14
|
50
|
|
|
|
56
|
} |
578
|
14
|
|
|
|
|
72
|
# generate help when there is no subcommand specified |
579
|
|
|
|
|
|
|
my $res = Perinci::CmdLine::Help::gen_help( |
580
|
|
|
|
|
|
|
meta => {v=>1.1}, |
581
|
14
|
|
|
|
|
30
|
common_opts => $cd->{copts}, |
|
104
|
|
|
|
|
373
|
|
|
132
|
|
|
|
|
325
|
|
|
14
|
|
|
|
|
60
|
|
582
|
|
|
|
|
|
|
program_name => $cd->{script_name}, |
583
|
|
|
|
|
|
|
program_summary => $cd->{gen_args}{script_summary}, |
584
|
14
|
50
|
|
|
|
78753
|
subcommands => $cd->{gen_args}{subcommands}, |
585
|
|
|
|
|
|
|
); |
586
|
14
|
|
|
|
|
53
|
return [500, "Can't generate help (subcommand=''): $res->[0] - $res->[1]"] |
587
|
|
|
|
|
|
|
unless $res->[0] == 200; |
588
|
|
|
|
|
|
|
$helps{''} = $res->[2]; |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
$cd->{helps} = \%helps; |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
push @l, 'my $help_msg = ', dmp($cd->{helps}{''}), ";\n"; |
594
|
|
|
|
|
|
|
|
595
|
9
|
|
|
|
|
74
|
my @sc_names = sort keys %{ $cd->{metas} }; |
596
|
9
|
50
|
|
|
|
47476
|
|
597
|
|
|
|
|
|
|
for my $stage (1, 2) { |
598
|
9
|
|
|
|
|
36
|
if ($stage == 1) { |
599
|
|
|
|
|
|
|
push @l, 'my $go_spec1 = {', "\n"; |
600
|
9
|
|
|
|
|
99
|
} else { |
601
|
|
|
|
|
|
|
push @l, 'my $go_spec2 = {', "\n"; |
602
|
|
|
|
|
|
|
push @l, " options => {\n"; |
603
|
9
|
|
|
|
|
58
|
} |
604
|
|
|
|
|
|
|
|
605
|
9
|
|
|
|
|
813
|
# common options |
|
9
|
|
|
|
|
58
|
|
606
|
|
|
|
|
|
|
my $ggl_res = $cd->{ggl_res}{$sc_names[0]}; |
607
|
9
|
|
|
|
|
30
|
my $specmetas = $ggl_res->[3]{'func.specmeta'}; |
608
|
18
|
100
|
|
|
|
58
|
for my $o (sort keys %$specmetas) { |
609
|
9
|
|
|
|
|
75
|
my $specmeta = $specmetas->{$o}; |
610
|
|
|
|
|
|
|
my $co = $specmeta->{common_opt}; |
611
|
9
|
|
|
|
|
20
|
next unless $co; |
612
|
9
|
|
|
|
|
54
|
if ($stage == 1) { |
613
|
|
|
|
|
|
|
push @l, " '$o' => sub { ", _gen_common_opt_handler($cd, $co), " },\n"; |
614
|
|
|
|
|
|
|
} else { |
615
|
|
|
|
|
|
|
push @l, " '$o' => {\n"; |
616
|
18
|
|
|
|
|
68
|
if ($co eq 'cmd') { |
617
|
18
|
|
|
|
|
33
|
push @l, " handler => sub { ", _gen_common_opt_handler($cd, $co), " },\n"; |
618
|
18
|
|
|
|
|
135
|
} else { |
619
|
214
|
|
|
|
|
325
|
push @l, " handler => sub {},\n"; |
620
|
214
|
|
|
|
|
284
|
} |
621
|
214
|
100
|
|
|
|
316
|
push @l, " },\n"; |
622
|
174
|
100
|
|
|
|
258
|
} |
623
|
87
|
|
|
|
|
225
|
} |
624
|
|
|
|
|
|
|
if ($stage == 1) { |
625
|
87
|
|
|
|
|
169
|
push @l, "};\n"; # end of %go_spec1 |
626
|
87
|
100
|
|
|
|
119
|
} else { |
627
|
9
|
|
|
|
|
32
|
push @l, " },\n"; # end of options |
628
|
|
|
|
|
|
|
} |
629
|
78
|
|
|
|
|
109
|
|
630
|
|
|
|
|
|
|
if ($stage == 2) { |
631
|
87
|
|
|
|
|
143
|
# subcommand options |
632
|
|
|
|
|
|
|
push @l, " subcommands => {\n"; |
633
|
|
|
|
|
|
|
for my $sc_name (sort keys %{ $cd->{metas} }) { |
634
|
18
|
100
|
|
|
|
55
|
my $meta = $cd->{metas}{$sc_name}; |
635
|
9
|
|
|
|
|
56
|
push @l, " '$sc_name' => {\n"; |
636
|
|
|
|
|
|
|
push @l, " options => {\n"; |
637
|
9
|
|
|
|
|
17
|
my $ggl_res = $cd->{ggl_res}{$sc_name}; |
638
|
|
|
|
|
|
|
my $specmetas = $ggl_res->[3]{'func.specmeta'}; |
639
|
|
|
|
|
|
|
for my $o (sort keys %$specmetas) { |
640
|
18
|
100
|
|
|
|
62
|
my $specmeta = $specmetas->{$o}; |
641
|
|
|
|
|
|
|
my $argname = $specmeta->{arg}; # XXX can't handle submetadata yet |
642
|
9
|
|
|
|
|
26
|
next unless defined $argname; |
643
|
9
|
|
|
|
|
18
|
my $arg_spec = $meta->{args}{$argname}; |
|
9
|
|
|
|
|
30
|
|
644
|
14
|
|
|
|
|
29
|
push @l, " '$o' => {\n"; |
645
|
14
|
|
|
|
|
40
|
push @l, " handler => sub { "; |
646
|
14
|
|
|
|
|
25
|
if ($specmeta->{is_alias} && $specmeta->{is_code}) { |
647
|
14
|
|
|
|
|
27
|
my $alias_spec = $arg_spec->{cmdline_aliases}{$specmeta->{alias}}; |
648
|
14
|
|
|
|
|
30
|
if ($specmeta->{is_code}) { |
649
|
14
|
|
|
|
|
69
|
push @l, 'my $code = ', dmp($alias_spec->{code}), '; '; |
650
|
157
|
|
|
|
|
198
|
push @l, '$code->(\%_pci_args);'; |
651
|
157
|
|
|
|
|
202
|
} else { |
652
|
157
|
100
|
|
|
|
242
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];'; |
653
|
25
|
|
|
|
|
39
|
} |
654
|
25
|
|
|
|
|
69
|
} else { |
655
|
25
|
|
|
|
|
46
|
if (($specmeta->{parsed}{type} // '') =~ /\@/) { |
656
|
25
|
50
|
33
|
|
|
68
|
push @l, 'if ($mentioned_args{\'', $specmeta->{arg}, '\'}++) { push @{ $_pci_args{\'', $specmeta->{arg}, '\'} }, $_[1] } else { $_pci_args{\'', $specmeta->{arg}, '\'} = [$_[1]] }'; |
657
|
0
|
|
|
|
|
0
|
} elsif ($specmeta->{is_json}) { |
658
|
0
|
0
|
|
|
|
0
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = _pci_json()->decode($_[1]);'; |
659
|
0
|
|
|
|
|
0
|
} elsif ($specmeta->{is_neg}) { |
660
|
0
|
|
|
|
|
0
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = 0;'; |
661
|
|
|
|
|
|
|
} else { |
662
|
0
|
|
|
|
|
0
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];'; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
} |
665
|
25
|
50
|
50
|
|
|
127
|
push @l, " },\n"; # end of handler |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
666
|
0
|
|
|
|
|
0
|
push @l, " },\n"; # end of option |
667
|
|
|
|
|
|
|
} |
668
|
10
|
|
|
|
|
39
|
push @l, " },\n"; # end of options |
669
|
|
|
|
|
|
|
push @l, " },\n"; # end of subcommand |
670
|
0
|
|
|
|
|
0
|
} |
671
|
|
|
|
|
|
|
push @l, " },\n"; # end of subcommands |
672
|
15
|
|
|
|
|
46
|
push @l, " default_subcommand => ".dmp($cd->{gen_args}{default_subcommand}).",\n"; |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
push @l, "};\n"; # end of %go_spec2 |
675
|
25
|
|
|
|
|
67
|
} # subcommand options |
676
|
25
|
|
|
|
|
52
|
} # stage |
677
|
|
|
|
|
|
|
|
678
|
14
|
|
|
|
|
45
|
push @l, "{\n"; |
679
|
14
|
|
|
|
|
31
|
push @l, ' local @ARGV = @ARGV;', "\n"; |
680
|
|
|
|
|
|
|
push @l, ' my $old_conf = Getopt::Long::EvenLess::Configure("pass_through");', "\n"; |
681
|
9
|
|
|
|
|
34
|
push @l, ' Getopt::Long::EvenLess::GetOptions(%$go_spec1);', "\n"; |
682
|
9
|
|
|
|
|
41
|
push @l, ' Getopt::Long::EvenLess::Configure($old_conf);', "\n"; |
683
|
|
|
|
|
|
|
push @l, ' { my $first_non_opt_arg; for (@ARGV) { next if /^-/; $first_non_opt_arg = $_; last } if (!length $_pci_r->{subcommand_name} && defined $first_non_opt_arg) { $_pci_r->{subcommand_name} = $first_non_opt_arg } }', "\n"; |
684
|
9
|
|
|
|
|
305
|
push @l, ' if (!length $_pci_r->{subcommand_name}) { $_pci_r->{subcommand_name} = '.dmp($cd->{gen_args}{default_subcommand}).' } ' if defined $cd->{gen_args}{default_subcommand}; |
685
|
|
|
|
|
|
|
push @l, "}\n"; |
686
|
|
|
|
|
|
|
push @l, _gen_read_env($cd); |
687
|
|
|
|
|
|
|
push @l, _gen_read_config($cd); |
688
|
9
|
|
|
|
|
22
|
push @l, 'my $res = Getopt::Long::Subcommand::GetOptions(%$go_spec2);', "\n"; |
689
|
9
|
|
|
|
|
26
|
push @l, '_pci_debug("args after GetOptions: ", \%_pci_args);', "\n" if $cd->{gen_args}{with_debug}; |
690
|
9
|
|
|
|
|
21
|
push @l, '_pci_err([500, "GetOptions failed"]) unless $res->{success};', "\n"; |
691
|
9
|
|
|
|
|
32
|
push @l, 'if (!length $_pci_r->{subcommand_name}) { print $help_msg; exit 0 }', "\n"; |
692
|
9
|
|
|
|
|
53
|
|
693
|
9
|
|
|
|
|
54
|
} else { |
694
|
9
|
100
|
|
|
|
55
|
|
695
|
9
|
|
|
|
|
94
|
my $meta = $cd->{metas}{''}; |
696
|
9
|
|
|
|
|
36
|
# stage 1 is catching common options only (--help, etc) |
697
|
9
|
|
|
|
|
64
|
for my $stage (1, 2) { |
698
|
9
|
|
|
|
|
24
|
push @l, "my \$go_spec$stage = {\n"; |
699
|
9
|
50
|
|
|
|
32
|
for my $go_spec (sort keys %{ $cd->{ggl_res}{''}[2] }) { |
700
|
9
|
|
|
|
|
22
|
my $specmeta = $cd->{ggl_res}{''}[3]{'func.specmeta'}{$go_spec}; |
701
|
9
|
|
|
|
|
62
|
my $co = $specmeta->{common_opt}; |
702
|
|
|
|
|
|
|
next if $stage == 1 && !$co; |
703
|
|
|
|
|
|
|
push @l, " '$go_spec' => sub { "; # begin option handler |
704
|
|
|
|
|
|
|
if ($co) { |
705
|
39
|
|
|
|
|
286
|
if ($stage == 1) { |
706
|
|
|
|
|
|
|
push @l, _gen_common_opt_handler($cd, $co); |
707
|
39
|
|
|
|
|
217
|
} else { |
708
|
78
|
|
|
|
|
384
|
# empty, we've done handling common options in stage 1 |
709
|
78
|
|
|
|
|
179
|
} |
|
78
|
|
|
|
|
697
|
|
710
|
900
|
|
|
|
|
1560
|
} else { |
711
|
900
|
|
|
|
|
1201
|
my $arg_spec = $meta->{args}{$specmeta->{arg}}; |
712
|
900
|
100
|
100
|
|
|
2140
|
push @l, ' '; |
713
|
762
|
|
|
|
|
1572
|
if ($stage == 1) { |
714
|
762
|
100
|
|
|
|
1090
|
# in stage 1, we do not yet deal with argument options |
715
|
624
|
100
|
|
|
|
897
|
} elsif ($specmeta->{is_alias} && $specmeta->{is_code}) { |
716
|
312
|
|
|
|
|
551
|
my $alias_spec = $arg_spec->{cmdline_aliases}{$specmeta->{alias}}; |
717
|
|
|
|
|
|
|
if ($specmeta->{is_code}) { |
718
|
|
|
|
|
|
|
push @l, 'my $code = ', dmp($alias_spec->{code}), '; '; |
719
|
|
|
|
|
|
|
push @l, '$code->(\%_pci_args);'; |
720
|
|
|
|
|
|
|
} else { |
721
|
138
|
|
|
|
|
279
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];'; |
722
|
138
|
|
|
|
|
324
|
} |
723
|
138
|
50
|
66
|
|
|
470
|
} else { |
|
|
50
|
|
|
|
|
|
724
|
|
|
|
|
|
|
if (($specmeta->{parsed}{type} // '') =~ /\@/) { |
725
|
|
|
|
|
|
|
push @l, 'if ($mentioned_args{\'', $specmeta->{arg}, '\'}++) { push @{ $_pci_args{\'', $specmeta->{arg}, '\'} }, $_[1] } else { $_pci_args{\'', $specmeta->{arg}, '\'} = [$_[1]] }'; |
726
|
0
|
|
|
|
|
0
|
} elsif ($specmeta->{is_json}) { |
727
|
0
|
0
|
|
|
|
0
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = _pci_json()->decode($_[1]);'; |
728
|
0
|
|
|
|
|
0
|
} elsif ($specmeta->{is_neg}) { |
729
|
0
|
|
|
|
|
0
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = 0;'; |
730
|
|
|
|
|
|
|
} else { |
731
|
0
|
|
|
|
|
0
|
push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];'; |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
} |
734
|
138
|
100
|
100
|
|
|
789
|
push @l, "\n"; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
735
|
8
|
|
|
|
|
105
|
} |
736
|
|
|
|
|
|
|
push @l, " },\n"; # end option handler |
737
|
59
|
|
|
|
|
295
|
} # options |
738
|
|
|
|
|
|
|
push @l, "};\n"; |
739
|
10
|
|
|
|
|
34
|
} # stage |
740
|
|
|
|
|
|
|
push @l, 'my $old_conf = Getopt::Long::EvenLess::Configure("pass_through");', "\n"; |
741
|
61
|
|
|
|
|
239
|
push @l, 'Getopt::Long::EvenLess::GetOptions(%$go_spec1);', "\n"; |
742
|
|
|
|
|
|
|
push @l, 'Getopt::Long::EvenLess::Configure($old_conf);', "\n"; |
743
|
|
|
|
|
|
|
push @l, _gen_read_env($cd); |
744
|
138
|
|
|
|
|
343
|
push @l, _gen_read_config($cd); |
745
|
|
|
|
|
|
|
push @l, 'my $res = Getopt::Long::EvenLess::GetOptions(%$go_spec2);', "\n"; |
746
|
762
|
|
|
|
|
1403
|
push @l, '_pci_err([500, "GetOptions failed"]) unless $res;', "\n"; |
747
|
|
|
|
|
|
|
push @l, '_pci_debug("args after GetOptions (stage 2): ", \%_pci_args);', "\n" if $cd->{gen_args}{with_debug}; |
748
|
78
|
|
|
|
|
379
|
|
749
|
|
|
|
|
|
|
} |
750
|
39
|
|
|
|
|
276
|
|
751
|
39
|
|
|
|
|
328
|
join "", @l; |
752
|
39
|
|
|
|
|
115
|
} |
753
|
39
|
|
|
|
|
137
|
|
754
|
39
|
|
|
|
|
281
|
# keep synchronize with Perinci::CmdLine::Base |
755
|
39
|
|
|
|
|
251
|
my %pericmd_attrs = ( |
756
|
39
|
|
|
|
|
255
|
|
757
|
39
|
50
|
|
|
|
201
|
# the currently unsupported/unused/irrelevant |
758
|
|
|
|
|
|
|
(map {( |
759
|
|
|
|
|
|
|
$_ => { |
760
|
|
|
|
|
|
|
schema => 'any*', |
761
|
48
|
|
|
|
|
1218
|
}, |
762
|
|
|
|
|
|
|
)} qw/actions common_opts completion |
763
|
|
|
|
|
|
|
default_format |
764
|
|
|
|
|
|
|
description exit formats |
765
|
|
|
|
|
|
|
riap_client riap_version riap_client_args |
766
|
|
|
|
|
|
|
tags |
767
|
|
|
|
|
|
|
get_subcommand_from_arg |
768
|
|
|
|
|
|
|
/), |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
pass_cmdline_object => { |
771
|
|
|
|
|
|
|
summary => 'Whether to pass Perinci::CmdLine::Inline object', |
772
|
|
|
|
|
|
|
schema => 'bool*', |
773
|
|
|
|
|
|
|
default => 0, |
774
|
|
|
|
|
|
|
}, |
775
|
|
|
|
|
|
|
script_name => { |
776
|
|
|
|
|
|
|
schema => 'str*', |
777
|
|
|
|
|
|
|
}, |
778
|
|
|
|
|
|
|
script_summary => { |
779
|
|
|
|
|
|
|
schema => 'str*', |
780
|
|
|
|
|
|
|
}, |
781
|
|
|
|
|
|
|
script_version => { |
782
|
|
|
|
|
|
|
summary => 'Script version (otherwise will use version from url metadata)', |
783
|
|
|
|
|
|
|
schema => 'str', |
784
|
|
|
|
|
|
|
}, |
785
|
|
|
|
|
|
|
script_version_from_main_version => { |
786
|
|
|
|
|
|
|
summary => "Use script's \$main::VERSION for the version", |
787
|
|
|
|
|
|
|
schema => 'bool*', |
788
|
|
|
|
|
|
|
}, |
789
|
|
|
|
|
|
|
url => { |
790
|
|
|
|
|
|
|
summary => 'Program URL', |
791
|
|
|
|
|
|
|
schema => 'riap::url*', |
792
|
|
|
|
|
|
|
pos => 0, |
793
|
|
|
|
|
|
|
}, |
794
|
|
|
|
|
|
|
extra_urls_for_version => { |
795
|
|
|
|
|
|
|
summary => 'More URLs to show version for --version', |
796
|
|
|
|
|
|
|
description => <<'_', |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
Currently not implemented in Perinci::CmdLine::Inline. |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
_ |
801
|
|
|
|
|
|
|
schema => ['array*', of=>'riap::url*'], |
802
|
|
|
|
|
|
|
}, |
803
|
|
|
|
|
|
|
skip_format => { |
804
|
|
|
|
|
|
|
summary => 'Assume that function returns raw text that need '. |
805
|
|
|
|
|
|
|
'no formatting, do not offer --format, --json, --naked-res', |
806
|
|
|
|
|
|
|
schema => 'bool*', |
807
|
|
|
|
|
|
|
default => 0, |
808
|
|
|
|
|
|
|
}, |
809
|
|
|
|
|
|
|
use_utf8 => { |
810
|
|
|
|
|
|
|
summary => 'Whether to set utf8 flag on output', |
811
|
|
|
|
|
|
|
schema => 'bool*', |
812
|
|
|
|
|
|
|
default => 0, |
813
|
|
|
|
|
|
|
}, |
814
|
|
|
|
|
|
|
use_cleanser => { |
815
|
|
|
|
|
|
|
summary => 'Whether to use data cleanser routine first before producing JSON', |
816
|
|
|
|
|
|
|
schema => 'bool*', |
817
|
|
|
|
|
|
|
default => 1, |
818
|
|
|
|
|
|
|
description => <<'_', |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
When a function returns result, and the user wants to display the result as |
821
|
|
|
|
|
|
|
JSON, the result might need to be cleansed first (e.g. using <pm:Data::Clean>) |
822
|
|
|
|
|
|
|
before it can be encoded to JSON, for example it might contain Perl objects or |
823
|
|
|
|
|
|
|
scalar references or other stuffs. If you are sure that your function does not |
824
|
|
|
|
|
|
|
produce those kinds of data, you can set this to false to produce a more |
825
|
|
|
|
|
|
|
lightweight script. |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
_ |
828
|
|
|
|
|
|
|
}, |
829
|
|
|
|
|
|
|
); |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
$SPEC{gen_inline_pericmd_script} = { |
832
|
|
|
|
|
|
|
v => 1.1, |
833
|
|
|
|
|
|
|
summary => 'Generate inline Perinci::CmdLine CLI script', |
834
|
|
|
|
|
|
|
description => <<'_', |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
The goal of this module is to let you create a CLI script from a Riap |
837
|
|
|
|
|
|
|
function/metadata. This is like what <pm:Perinci::CmdLine::Lite> or |
838
|
|
|
|
|
|
|
<pm:Perinci::CmdLine::Classic> does, except that the generated CLI script will have |
839
|
|
|
|
|
|
|
the functionalities inlined so it only need core Perl modules and not any of the |
840
|
|
|
|
|
|
|
`Perinci::CmdLine::*` or other modules to run (excluding what modules the Riap |
841
|
|
|
|
|
|
|
function itself requires). |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
It's useful if you want a CLI script that is even more lightweight (in terms of |
844
|
|
|
|
|
|
|
startup overhead or dependencies) than the one using <pm:Perinci::CmdLine::Lite>. |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
So to reiterate, the goal of this module is to create a Perinci::CmdLine-based |
847
|
|
|
|
|
|
|
script which only requires core modules, and has as little startup overhead as |
848
|
|
|
|
|
|
|
possible. |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
Currently it only supports a subset of features compared to other |
851
|
|
|
|
|
|
|
`Perinci::CmdLine::*` implementations: |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
* Only support local Riap URL (e.g. `/Foo/bar`, not |
854
|
|
|
|
|
|
|
`http://example.org/Foo/bar`); |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
As an alternative to this module, if you are looking to reduce dependencies, you |
857
|
|
|
|
|
|
|
might also want to try using `depak` to fatpack/datapack your |
858
|
|
|
|
|
|
|
<pm:Perinci::CmdLine::Lite>-based script. |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
_ |
861
|
|
|
|
|
|
|
args_rels => { |
862
|
|
|
|
|
|
|
'dep_any&' => [ |
863
|
|
|
|
|
|
|
[meta_is_normalized => ['meta']], |
864
|
|
|
|
|
|
|
[default_subcommand => ['subcommands']], |
865
|
|
|
|
|
|
|
], |
866
|
|
|
|
|
|
|
'req_one&' => [ |
867
|
|
|
|
|
|
|
[qw/url meta/], |
868
|
|
|
|
|
|
|
[qw/url subcommands/], |
869
|
|
|
|
|
|
|
], |
870
|
|
|
|
|
|
|
'choose_all&' => [ |
871
|
|
|
|
|
|
|
[qw/meta sub_name/], |
872
|
|
|
|
|
|
|
], |
873
|
|
|
|
|
|
|
}, |
874
|
|
|
|
|
|
|
args => { |
875
|
|
|
|
|
|
|
(map { |
876
|
|
|
|
|
|
|
$_ => { |
877
|
|
|
|
|
|
|
%{ $pericmd_attrs{$_} }, |
878
|
|
|
|
|
|
|
summary => $pericmd_attrs{$_}{summary} // 'Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base', |
879
|
|
|
|
|
|
|
tags => ['category:pericmd-attribute'], |
880
|
|
|
|
|
|
|
}, |
881
|
|
|
|
|
|
|
} keys %pericmd_attrs), |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
meta => { |
884
|
|
|
|
|
|
|
summary => 'An alternative to specifying `url`', |
885
|
|
|
|
|
|
|
schema => 'hash', |
886
|
|
|
|
|
|
|
tags => ['category:input'], |
887
|
|
|
|
|
|
|
}, |
888
|
|
|
|
|
|
|
meta_is_normalized => { |
889
|
|
|
|
|
|
|
schema => 'bool', |
890
|
|
|
|
|
|
|
tags => ['category:input'], |
891
|
|
|
|
|
|
|
}, |
892
|
|
|
|
|
|
|
sub_name => { |
893
|
|
|
|
|
|
|
schema => 'str*', |
894
|
|
|
|
|
|
|
tags => ['category:input'], |
895
|
|
|
|
|
|
|
}, |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
subcommands => { |
898
|
|
|
|
|
|
|
schema => ['hash*', of=>'hash*'], |
899
|
|
|
|
|
|
|
tags => ['category:input'], |
900
|
|
|
|
|
|
|
}, |
901
|
|
|
|
|
|
|
default_subcommand => { |
902
|
|
|
|
|
|
|
schema => 'str*', |
903
|
|
|
|
|
|
|
tags => ['category:input'], |
904
|
|
|
|
|
|
|
}, |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
shebang => { |
907
|
|
|
|
|
|
|
summary => 'Set shebang line', |
908
|
|
|
|
|
|
|
schema => 'str*', |
909
|
|
|
|
|
|
|
}, |
910
|
|
|
|
|
|
|
validate_args => { |
911
|
|
|
|
|
|
|
summary => 'Whether the CLI script should validate arguments using schemas', |
912
|
|
|
|
|
|
|
schema => 'bool', |
913
|
|
|
|
|
|
|
default => 1, |
914
|
|
|
|
|
|
|
}, |
915
|
|
|
|
|
|
|
#validate_result => { |
916
|
|
|
|
|
|
|
# summary => 'Whether the CLI script should validate result using schemas', |
917
|
|
|
|
|
|
|
# schema => 'bool', |
918
|
|
|
|
|
|
|
# default => 1, |
919
|
|
|
|
|
|
|
#}, |
920
|
|
|
|
|
|
|
read_config => { |
921
|
|
|
|
|
|
|
summary => 'Whether the CLI script should read configuration files', |
922
|
|
|
|
|
|
|
schema => 'bool*', |
923
|
|
|
|
|
|
|
default => 1, |
924
|
|
|
|
|
|
|
}, |
925
|
|
|
|
|
|
|
config_filename => { |
926
|
|
|
|
|
|
|
summary => 'Configuration file name(s)', |
927
|
|
|
|
|
|
|
schema => ['any*', of=>[ |
928
|
|
|
|
|
|
|
'str*', |
929
|
|
|
|
|
|
|
'hash*', |
930
|
|
|
|
|
|
|
['array*', of=>['any*', of=>['str*','hash*']]], |
931
|
|
|
|
|
|
|
]], |
932
|
|
|
|
|
|
|
}, |
933
|
|
|
|
|
|
|
config_dirs => { |
934
|
|
|
|
|
|
|
'x.name.is_plural' => 1, |
935
|
|
|
|
|
|
|
'x.name.singular' => 'config_dir', |
936
|
|
|
|
|
|
|
summary => 'Where to search for configuration files', |
937
|
|
|
|
|
|
|
schema => ['array*', of=>'str*'], |
938
|
|
|
|
|
|
|
}, |
939
|
|
|
|
|
|
|
read_env => { |
940
|
|
|
|
|
|
|
summary => 'Whether CLI script should read environment variable that sets default options', |
941
|
|
|
|
|
|
|
schema => 'bool*', |
942
|
|
|
|
|
|
|
}, |
943
|
|
|
|
|
|
|
env_name => { |
944
|
|
|
|
|
|
|
summary => 'Name of environment variable name that sets default options', |
945
|
|
|
|
|
|
|
schema => 'str*', |
946
|
|
|
|
|
|
|
}, |
947
|
|
|
|
|
|
|
log => { |
948
|
|
|
|
|
|
|
summary => 'Whether to enable logging', |
949
|
|
|
|
|
|
|
schema => 'bool*', |
950
|
|
|
|
|
|
|
default => 0, |
951
|
|
|
|
|
|
|
}, |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
with_debug => { |
954
|
|
|
|
|
|
|
summary => 'Generate script with debugging outputs', |
955
|
|
|
|
|
|
|
schema => 'bool', |
956
|
|
|
|
|
|
|
tags => ['category:debugging'], |
957
|
|
|
|
|
|
|
}, |
958
|
|
|
|
|
|
|
include => { |
959
|
|
|
|
|
|
|
summary => 'Include extra modules', |
960
|
|
|
|
|
|
|
'summary.alt.plurality.singular' => 'Include an extra module', |
961
|
|
|
|
|
|
|
schema => ['array*', of=>'perl::modname*'], |
962
|
|
|
|
|
|
|
cmdline_aliases => {I=>{}}, |
963
|
|
|
|
|
|
|
}, |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
code_after_shebang => { |
966
|
|
|
|
|
|
|
summary => 'Put at the very beginning of generated script, after the shebang line', |
967
|
|
|
|
|
|
|
schema => 'str*', |
968
|
|
|
|
|
|
|
tags => ['category:extra-code'], |
969
|
|
|
|
|
|
|
}, |
970
|
|
|
|
|
|
|
code_before_parse_cmdline_options => { |
971
|
|
|
|
|
|
|
schema => 'str*', |
972
|
|
|
|
|
|
|
tags => ['category:extra-code'], |
973
|
|
|
|
|
|
|
}, |
974
|
|
|
|
|
|
|
code_before_enable_logging => { |
975
|
|
|
|
|
|
|
schema => 'str*', |
976
|
|
|
|
|
|
|
tags => ['category:extra-code'], |
977
|
|
|
|
|
|
|
}, |
978
|
|
|
|
|
|
|
code_add_extra_log_outputs => { |
979
|
|
|
|
|
|
|
schema => 'str*', |
980
|
|
|
|
|
|
|
tags => ['category:extra-code'], |
981
|
|
|
|
|
|
|
}, |
982
|
|
|
|
|
|
|
code_after_enable_logging => { |
983
|
|
|
|
|
|
|
schema => 'str*', |
984
|
|
|
|
|
|
|
tags => ['category:extra-code'], |
985
|
|
|
|
|
|
|
}, |
986
|
|
|
|
|
|
|
code_after_end => { |
987
|
|
|
|
|
|
|
summary => 'Put at the very end of generated script', |
988
|
|
|
|
|
|
|
schema => 'str*', |
989
|
|
|
|
|
|
|
tags => ['category:extra-code'], |
990
|
|
|
|
|
|
|
}, |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
allow_prereq => { |
993
|
|
|
|
|
|
|
summary => 'A list of modules that can be depended upon', |
994
|
|
|
|
|
|
|
schema => ['array*', of=>'str*'], # XXX perl::modname |
995
|
|
|
|
|
|
|
description => <<'_', |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
By default, Perinci::CmdLine::Inline will strive to make the script freestanding |
998
|
|
|
|
|
|
|
and require only core Perl modules. A dependency to a non-core module will cause |
999
|
|
|
|
|
|
|
failure (unless `pack_deps` option is set to false). However, you can pass a |
1000
|
|
|
|
|
|
|
list of modules that is allowed here. |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
_ |
1003
|
|
|
|
|
|
|
}, |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
pack_deps => { |
1006
|
|
|
|
|
|
|
summary => 'Whether to pack dependencies into the script', |
1007
|
|
|
|
|
|
|
schema => ['bool*'], |
1008
|
|
|
|
|
|
|
default => 1, |
1009
|
|
|
|
|
|
|
description => <<'_', |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
By default, Perinci::CmdLine::Inline will use datapacking technique (i.e. embed |
1012
|
|
|
|
|
|
|
dependencies into DATA section and load it on-demand using require() hook) to |
1013
|
|
|
|
|
|
|
make the script freestanding. However, in some situation this is unwanted, e.g. |
1014
|
|
|
|
|
|
|
when we want to produce a script that can be packaged as a Debian package |
1015
|
|
|
|
|
|
|
(Debian policy forbids embedding convenience copy of code, |
1016
|
|
|
|
|
|
|
https://www.debian.org/doc/debian-policy/ch-source.html#s-embeddedfiles ). |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
_ |
1019
|
|
|
|
|
|
|
}, |
1020
|
|
|
|
|
|
|
pod => { |
1021
|
|
|
|
|
|
|
summary => 'Whether to generate POD for the script', |
1022
|
|
|
|
|
|
|
schema => ['bool*'], |
1023
|
|
|
|
|
|
|
default => 1, |
1024
|
|
|
|
|
|
|
}, |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
output_file => { |
1027
|
|
|
|
|
|
|
summary => 'Set output file, defaults to stdout', |
1028
|
|
|
|
|
|
|
schema => 'filename*', |
1029
|
|
|
|
|
|
|
cmdline_aliases => {o=>{}}, |
1030
|
|
|
|
|
|
|
tags => ['category:output'], |
1031
|
|
|
|
|
|
|
}, |
1032
|
|
|
|
|
|
|
overwrite => { |
1033
|
|
|
|
|
|
|
schema => 'bool', |
1034
|
|
|
|
|
|
|
tags => ['category:output'], |
1035
|
|
|
|
|
|
|
}, |
1036
|
|
|
|
|
|
|
stripper => { |
1037
|
|
|
|
|
|
|
summary => 'Whether to strip code using Perl::Stripper', |
1038
|
|
|
|
|
|
|
schema => 'bool*', |
1039
|
|
|
|
|
|
|
default => 0, |
1040
|
|
|
|
|
|
|
}, |
1041
|
|
|
|
|
|
|
}, |
1042
|
|
|
|
|
|
|
}; |
1043
|
|
|
|
|
|
|
require Data::Sah::Util::Type; |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
my %args = @_; |
1046
|
|
|
|
|
|
|
$args{url} = "$args{url}"; # stringify URI object to avoid JSON encoder croaking |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
# XXX schema |
1049
|
|
|
|
|
|
|
$args{validate_args} //= 1; |
1050
|
|
|
|
|
|
|
#$args{validate_result} //= 1; |
1051
|
|
|
|
|
|
|
$args{pack_deps} //= 1; |
1052
|
|
|
|
|
|
|
$args{read_config} //= 1; |
1053
|
|
|
|
|
|
|
$args{read_env} //= 1; |
1054
|
50
|
|
|
50
|
1
|
3339687
|
$args{use_cleanser} //= 1; |
1055
|
|
|
|
|
|
|
|
1056
|
50
|
|
|
|
|
3513
|
my $cd = { |
1057
|
50
|
|
|
|
|
465
|
gen_args => \%args, |
1058
|
|
|
|
|
|
|
script_name => $args{script_name}, |
1059
|
|
|
|
|
|
|
req_modules => {}, # modules which we will 'require' at the beginning of script. currently unused. |
1060
|
50
|
|
50
|
|
|
807
|
vars => {}, |
1061
|
|
|
|
|
|
|
subs => {}, |
1062
|
50
|
|
50
|
|
|
514
|
module_srcs => {}, |
1063
|
50
|
|
50
|
|
|
201
|
core_deps => {}, # core modules required by the generated script. so we can specify dependencies to it, in environments where not all core modules are available. |
1064
|
50
|
|
50
|
|
|
183
|
}; |
1065
|
50
|
|
50
|
|
|
472
|
|
1066
|
|
|
|
|
|
|
GET_META: |
1067
|
|
|
|
|
|
|
{ |
1068
|
|
|
|
|
|
|
my %metas; # key=subcommand name, '' if no subcommands |
1069
|
|
|
|
|
|
|
my %mods; # key=module name, value={version=>..., ...} |
1070
|
50
|
|
|
|
|
901
|
my %sc_mods; # key=subcommand name, value=module name |
1071
|
|
|
|
|
|
|
my %func_names; # key=subcommand name, value=qualified function name |
1072
|
|
|
|
|
|
|
my $script_name = $args{script_name}; |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
my $scs = $args{subcommands}; |
1075
|
|
|
|
|
|
|
if ($scs) { |
1076
|
|
|
|
|
|
|
for my $sc_name (keys %$scs) { |
1077
|
|
|
|
|
|
|
my $sc_spec = $scs->{$sc_name}; |
1078
|
|
|
|
|
|
|
my $res = _get_meta_from_url($sc_spec->{url}); |
1079
|
50
|
|
|
|
|
147
|
return $res if $res->[0] != 200; |
|
50
|
|
|
|
|
244
|
|
1080
|
|
|
|
|
|
|
$mods{ $res->[3]{'func.module'} } = { |
1081
|
50
|
|
|
|
|
0
|
version => $res->[3]{'func.module_version'}, |
1082
|
50
|
|
|
|
|
0
|
}; |
1083
|
50
|
|
|
|
|
312
|
$metas{$sc_name} = $res->[2]; |
1084
|
|
|
|
|
|
|
$sc_mods{$sc_name} = $res->[3]{'func.module'}; |
1085
|
50
|
|
|
|
|
162
|
$func_names{$sc_name} = $res->[3]{'func.func_name'}; |
1086
|
50
|
100
|
|
|
|
221
|
} |
1087
|
9
|
|
|
|
|
86
|
} |
1088
|
14
|
|
|
|
|
53
|
|
1089
|
14
|
|
|
|
|
178
|
my $url = $args{url}; |
1090
|
14
|
50
|
|
|
|
75
|
if ($url) { |
1091
|
|
|
|
|
|
|
my $res = _get_meta_from_url($url); |
1092
|
14
|
|
|
|
|
112
|
return $res if $res->[0] != 200; |
1093
|
|
|
|
|
|
|
$mods{ $res->[3]{'func.module'} } = { |
1094
|
14
|
|
|
|
|
52
|
version => $res->[3]{'func.module_version'}, |
1095
|
14
|
|
|
|
|
65
|
}; |
1096
|
14
|
|
|
|
|
70
|
$sc_mods{''} = $res->[3]{'func.module'}; |
1097
|
|
|
|
|
|
|
unless ($scs) { |
1098
|
|
|
|
|
|
|
$metas{''} = $res->[2]; |
1099
|
|
|
|
|
|
|
$func_names{''} = $res->[3]{'func.func_name'}; |
1100
|
50
|
|
|
|
|
197
|
} |
1101
|
50
|
50
|
|
|
|
235
|
if (length (my $sfn = $res->[3]{'func.short_func_name'})) { |
1102
|
50
|
|
|
|
|
466
|
$script_name //= do { |
1103
|
50
|
50
|
|
|
|
246
|
local $_ = $sfn; |
1104
|
|
|
|
|
|
|
s/_/-/g; |
1105
|
50
|
|
|
|
|
356
|
$_; |
1106
|
|
|
|
|
|
|
}; |
1107
|
50
|
|
|
|
|
252
|
} |
1108
|
50
|
100
|
|
|
|
177
|
} |
1109
|
41
|
|
|
|
|
127
|
|
1110
|
41
|
|
|
|
|
122
|
if (!$url && !$scs) { |
1111
|
|
|
|
|
|
|
$metas{''} = $args{meta}; |
1112
|
50
|
100
|
|
|
|
468
|
$func_names{''} = $args{sub_name}; |
1113
|
41
|
|
66
|
|
|
341
|
$script_name //= do { |
1114
|
27
|
|
|
|
|
80
|
local $_ = $args{sub_name}; |
1115
|
27
|
|
|
|
|
182
|
s/_/-/g; |
1116
|
27
|
|
|
|
|
175
|
$_; |
1117
|
|
|
|
|
|
|
}; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
$script_name //= do { |
1121
|
50
|
0
|
33
|
|
|
208
|
local $_ = $0; |
1122
|
0
|
|
|
|
|
0
|
s!.+[/\\]!!; |
1123
|
0
|
|
|
|
|
0
|
$_; |
1124
|
0
|
|
0
|
|
|
0
|
}; |
1125
|
0
|
|
|
|
|
0
|
|
1126
|
0
|
|
|
|
|
0
|
last if $args{meta_is_normalized}; |
1127
|
0
|
|
|
|
|
0
|
require Perinci::Sub::Normalize; |
1128
|
|
|
|
|
|
|
for (keys %metas) { |
1129
|
|
|
|
|
|
|
$metas{$_} = Perinci::Sub::Normalize::normalize_function_metadata($metas{$_}); |
1130
|
|
|
|
|
|
|
} |
1131
|
50
|
|
66
|
|
|
191
|
|
1132
|
7
|
|
|
|
|
32
|
$cd->{script_name} = $script_name; |
1133
|
7
|
|
|
|
|
84
|
$cd->{metas} = \%metas; |
1134
|
7
|
|
|
|
|
37
|
$cd->{mods} = \%mods; |
1135
|
|
|
|
|
|
|
$cd->{sc_mods} = \%sc_mods; |
1136
|
|
|
|
|
|
|
$cd->{func_names} = \%func_names; |
1137
|
50
|
50
|
|
|
|
231
|
} # GET_META |
1138
|
50
|
|
|
|
|
385
|
|
1139
|
50
|
|
|
|
|
241
|
$args{config_filename} //= "$cd->{script_name}.conf"; |
1140
|
55
|
|
|
|
|
2496
|
$args{env_name} //= do { |
1141
|
|
|
|
|
|
|
my $env = uc "$cd->{script_name}_OPT"; |
1142
|
|
|
|
|
|
|
$env =~ s/[^A-Z0-9]+/_/g; |
1143
|
50
|
|
|
|
|
21036
|
$env = "_$env" if $env =~ /\A\d/; |
1144
|
50
|
|
|
|
|
458
|
$env; |
1145
|
50
|
|
|
|
|
364
|
}; |
1146
|
50
|
|
|
|
|
349
|
|
1147
|
50
|
|
|
|
|
429
|
for ( |
1148
|
|
|
|
|
|
|
# required by Perinci::Result::Format::Lite. this will be removed if we |
1149
|
|
|
|
|
|
|
# don't need formatting. |
1150
|
50
|
|
66
|
|
|
871
|
"Data::Check::Structure", |
1151
|
50
|
|
66
|
|
|
395
|
|
1152
|
49
|
|
|
|
|
331
|
# required by _pci_gen_iter. this will be removed if we don't need |
1153
|
49
|
|
|
|
|
599
|
# _pci_gen_iter |
1154
|
49
|
100
|
|
|
|
417
|
"Data::Sah::Util::Type", |
1155
|
49
|
|
|
|
|
197
|
|
1156
|
|
|
|
|
|
|
# this will be removed if we don't need formatting |
1157
|
|
|
|
|
|
|
"Perinci::Result::Format::Lite", |
1158
|
50
|
|
|
|
|
118
|
|
1159
|
|
|
|
|
|
|
# this will be removed if we don't need formatting |
1160
|
|
|
|
|
|
|
"Text::Table::Sprintf", |
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
@{ $args{include} // [] }, |
1163
|
|
|
|
|
|
|
) { |
1164
|
|
|
|
|
|
|
_pack_module($cd, $_); |
1165
|
|
|
|
|
|
|
} |
1166
|
|
|
|
|
|
|
|
1167
|
|
|
|
|
|
|
GEN_SCRIPT: |
1168
|
|
|
|
|
|
|
{ |
1169
|
|
|
|
|
|
|
my @l; |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
{ |
1172
|
|
|
|
|
|
|
require Perinci::CmdLine::Base; |
1173
|
50
|
|
100
|
|
|
267
|
no warnings 'once'; |
1174
|
|
|
|
|
|
|
my %copts; |
1175
|
246
|
|
|
|
|
964
|
$copts{help} = $Perinci::CmdLine::Base::copts{help}; |
1176
|
|
|
|
|
|
|
$copts{version} = $Perinci::CmdLine::Base::copts{version}; |
1177
|
|
|
|
|
|
|
if ($args{log}) { |
1178
|
|
|
|
|
|
|
$copts{log_level} = { |
1179
|
|
|
|
|
|
|
getopt => "log-level=s", |
1180
|
50
|
|
|
|
|
240
|
summary => "Set logging level (trace|debug|info|warn|error|fatal|none)", |
|
50
|
|
|
|
|
133
|
|
1181
|
|
|
|
|
|
|
}; |
1182
|
|
|
|
|
|
|
$copts{trace} = { |
1183
|
50
|
|
|
|
|
88
|
getopt => "trace", |
|
50
|
|
|
|
|
1707
|
|
1184
|
2
|
|
|
2
|
|
68
|
summary => "Set logging level to trace", |
|
2
|
|
|
|
|
16
|
|
|
2
|
|
|
|
|
5366
|
|
1185
|
50
|
|
|
|
|
98597
|
}; |
1186
|
50
|
|
|
|
|
375
|
$copts{debug} = { |
1187
|
50
|
|
|
|
|
349
|
getopt => "debug", |
1188
|
50
|
100
|
|
|
|
385
|
summary => "Set logging level to debug", |
1189
|
|
|
|
|
|
|
}; |
1190
|
1
|
|
|
|
|
27
|
$copts{verbose} = { |
1191
|
|
|
|
|
|
|
getopt => "verbose", |
1192
|
|
|
|
|
|
|
summary => "Set logging level to info", |
1193
|
|
|
|
|
|
|
}; |
1194
|
1
|
|
|
|
|
10
|
$copts{quiet} = { |
1195
|
|
|
|
|
|
|
getopt => "quiet", |
1196
|
|
|
|
|
|
|
summary => "Set logging level to error", |
1197
|
|
|
|
|
|
|
}; |
1198
|
1
|
|
|
|
|
10
|
|
1199
|
|
|
|
|
|
|
$cd->{vars}{'$_pci_log_outputs'} = {}; |
1200
|
|
|
|
|
|
|
} |
1201
|
|
|
|
|
|
|
unless ($args{skip_format}) { |
1202
|
1
|
|
|
|
|
9
|
$copts{json} = $Perinci::CmdLine::Base::copts{json}; |
1203
|
|
|
|
|
|
|
$copts{format} = $Perinci::CmdLine::Base::copts{format}; |
1204
|
|
|
|
|
|
|
# "naked_res!" currently not supported by |
1205
|
|
|
|
|
|
|
# Getopt::Long::EvenLess, so we split it. the downside is that |
1206
|
1
|
|
|
|
|
9
|
# we don't hide the default, by default. |
1207
|
|
|
|
|
|
|
$copts{naked_res} = { |
1208
|
|
|
|
|
|
|
getopt => "naked-res", |
1209
|
|
|
|
|
|
|
summary => "When outputing as JSON, strip result envelope", |
1210
|
1
|
|
|
|
|
8
|
}; |
1211
|
|
|
|
|
|
|
$copts{no_naked_res} = { |
1212
|
50
|
50
|
|
|
|
373
|
getopt => "no-naked-res|nonaked-res", |
1213
|
50
|
|
|
|
|
532
|
summary => "When outputing as JSON, don't strip result envelope", |
1214
|
50
|
|
|
|
|
460
|
}; |
1215
|
|
|
|
|
|
|
} |
1216
|
|
|
|
|
|
|
if ($args{subcommands}) { |
1217
|
|
|
|
|
|
|
$copts{subcommands} = $Perinci::CmdLine::Base::copts{subcommands}; |
1218
|
|
|
|
|
|
|
$copts{cmd} = $Perinci::CmdLine::Base::copts{cmd}; |
1219
|
50
|
|
|
|
|
799
|
} |
1220
|
|
|
|
|
|
|
if ($args{read_config}) { |
1221
|
|
|
|
|
|
|
for (qw/config_path no_config config_profile/) { |
1222
|
|
|
|
|
|
|
$copts{$_} = $Perinci::CmdLine::Base::copts{$_}; |
1223
|
50
|
|
|
|
|
477
|
} |
1224
|
|
|
|
|
|
|
} |
1225
|
|
|
|
|
|
|
if ($args{read_env}) { |
1226
|
|
|
|
|
|
|
for (qw/no_env/) { |
1227
|
50
|
100
|
|
|
|
228
|
$copts{$_} = $Perinci::CmdLine::Base::copts{$_}; |
1228
|
9
|
|
|
|
|
55
|
} |
1229
|
9
|
|
|
|
|
81
|
} |
1230
|
|
|
|
|
|
|
for (qw/page_result/) { |
1231
|
50
|
100
|
|
|
|
215
|
$copts{$_} = $Perinci::CmdLine::Base::copts{$_}; |
1232
|
12
|
|
|
|
|
102
|
} |
1233
|
36
|
|
|
|
|
238
|
$cd->{copts} = \%copts; |
1234
|
|
|
|
|
|
|
} |
1235
|
|
|
|
|
|
|
|
1236
|
50
|
100
|
|
|
|
210
|
my $shebang_line; |
1237
|
4
|
|
|
|
|
35
|
{ |
1238
|
4
|
|
|
|
|
51
|
$shebang_line = $args{shebang} // $^X; |
1239
|
|
|
|
|
|
|
$shebang_line = "#!$shebang_line" unless $shebang_line =~ /\A#!/; |
1240
|
|
|
|
|
|
|
$shebang_line .= "\n" unless $shebang_line =~ /\R\z/; |
1241
|
50
|
|
|
|
|
233
|
} |
1242
|
50
|
|
|
|
|
507
|
|
1243
|
|
|
|
|
|
|
# this will be removed if we don't use streaming input or read from |
1244
|
50
|
|
|
|
|
406
|
# stdin |
1245
|
|
|
|
|
|
|
$cd->{sub_srcs}{_pci_gen_iter} = <<'_'; |
1246
|
|
|
|
|
|
|
require Data::Sah::Util::Type; |
1247
|
50
|
|
|
|
|
153
|
my ($fh, $type, $argname) = @_; |
1248
|
|
|
|
|
|
|
if (Data::Sah::Util::Type::is_simple($type)) { |
1249
|
50
|
|
33
|
|
|
92
|
return sub { |
|
50
|
|
|
|
|
766
|
|
1250
|
50
|
50
|
|
|
|
371
|
# XXX this will be configurable later. currently by default reading |
1251
|
50
|
50
|
|
|
|
414
|
# binary is per-64k while reading string is line-by-line. |
1252
|
|
|
|
|
|
|
local $/ = \(64*1024) if $type eq 'buf'; |
1253
|
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
|
state $eof; |
1255
|
|
|
|
|
|
|
return undef if $eof; |
1256
|
50
|
|
|
|
|
483
|
my $l = <$fh>; |
1257
|
|
|
|
|
|
|
unless (defined $l) { |
1258
|
|
|
|
|
|
|
$eof++; return undef; |
1259
|
|
|
|
|
|
|
} |
1260
|
|
|
|
|
|
|
$l; |
1261
|
|
|
|
|
|
|
}; |
1262
|
|
|
|
|
|
|
} else { |
1263
|
|
|
|
|
|
|
my $i = -1; |
1264
|
|
|
|
|
|
|
return sub { |
1265
|
|
|
|
|
|
|
state $eof; |
1266
|
|
|
|
|
|
|
return undef if $eof; |
1267
|
|
|
|
|
|
|
$i++; |
1268
|
|
|
|
|
|
|
my $l = <$fh>; |
1269
|
|
|
|
|
|
|
unless (defined $l) { |
1270
|
|
|
|
|
|
|
$eof++; return undef; |
1271
|
|
|
|
|
|
|
} |
1272
|
|
|
|
|
|
|
eval { $l = _pci_json()->decode($l) }; |
1273
|
|
|
|
|
|
|
if ($@) { |
1274
|
|
|
|
|
|
|
die "Invalid JSON in stream argument '$argname' record #$i: $@"; |
1275
|
|
|
|
|
|
|
} |
1276
|
|
|
|
|
|
|
$l; |
1277
|
|
|
|
|
|
|
}; |
1278
|
|
|
|
|
|
|
} |
1279
|
|
|
|
|
|
|
_ |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
$cd->{sub_srcs}{_pci_err} = <<'_'; |
1282
|
|
|
|
|
|
|
my $res = shift; |
1283
|
|
|
|
|
|
|
print STDERR "ERROR $res->[0]: $res->[1]\n"; |
1284
|
|
|
|
|
|
|
exit $res->[0]-300; |
1285
|
|
|
|
|
|
|
_ |
1286
|
|
|
|
|
|
|
|
1287
|
|
|
|
|
|
|
if ($args{with_debug}) { |
1288
|
|
|
|
|
|
|
_pack_module($cd, "Data::Dmp"); |
1289
|
|
|
|
|
|
|
_pack_module($cd, "Regexp::Stringify"); # needed by Data::Dmp |
1290
|
|
|
|
|
|
|
$cd->{sub_srcs}{_pci_debug} = <<'_'; |
1291
|
|
|
|
|
|
|
require Data::Dmp; |
1292
|
50
|
|
|
|
|
457
|
print "DEBUG: ", Data::Dmp::dmp(@_), "\n"; |
1293
|
|
|
|
|
|
|
_ |
1294
|
|
|
|
|
|
|
} |
1295
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
$cd->{sub_srcs}{_pci_json} = <<'_'; |
1297
|
|
|
|
|
|
|
state $json = do { |
1298
|
50
|
50
|
|
|
|
247
|
if (eval { require JSON::XS; 1 }) { JSON::XS->new->canonical(1)->allow_nonref } |
1299
|
0
|
|
|
|
|
0
|
else { require JSON::PP; JSON::PP->new->canonical(1)->allow_nonref } |
1300
|
0
|
|
|
|
|
0
|
}; |
1301
|
0
|
|
|
|
|
0
|
$json; |
1302
|
|
|
|
|
|
|
_ |
1303
|
|
|
|
|
|
|
$cd->{sub_src_core_deps}{_pci_json}{'JSON::PP'} = 0; |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
{ |
1306
|
|
|
|
|
|
|
last unless $args{use_cleanser}; |
1307
|
50
|
|
|
|
|
376
|
require Module::CoreList; |
1308
|
|
|
|
|
|
|
require Data::Clean::JSON; |
1309
|
|
|
|
|
|
|
my $cleanser = Data::Clean::JSON->new( |
1310
|
|
|
|
|
|
|
# TODO: probably change back to using Storable since 3.08+ |
1311
|
|
|
|
|
|
|
# now support Regexp objects. |
1312
|
|
|
|
|
|
|
'!clone_func' => 'Clone::PP::clone', |
1313
|
|
|
|
|
|
|
); |
1314
|
50
|
|
|
|
|
557
|
my $src = $cleanser->{_cd}{src}; |
1315
|
|
|
|
|
|
|
my $src1 = 'sub _pci_clean_json { '; |
1316
|
|
|
|
|
|
|
for my $mod (keys %{ $cleanser->{_cd}{modules} }) { |
1317
|
50
|
50
|
|
|
|
192
|
$src1 .= "require $mod; "; |
1318
|
50
|
|
|
|
|
492
|
next if Module::CoreList->is_core($mod); |
1319
|
50
|
|
|
|
|
1535
|
_pack_module($cd, $mod); |
1320
|
50
|
|
|
|
|
8780
|
} |
1321
|
|
|
|
|
|
|
$cd->{module_srcs}{'Local::_pci_clean_json'} = "$src1 use feature 'state'; state \$cleanser = $src; \$cleanser->(shift) }\n1;\n"; |
1322
|
|
|
|
|
|
|
} |
1323
|
|
|
|
|
|
|
|
1324
|
|
|
|
|
|
|
{ |
1325
|
50
|
|
|
|
|
132879
|
require Perinci::Sub::GetArgs::Argv; |
1326
|
50
|
|
|
|
|
168
|
my %ggl_res; # key = subcommand name |
1327
|
50
|
|
|
|
|
135
|
my %args_as; # key = subcommand name |
|
50
|
|
|
|
|
335
|
|
1328
|
100
|
|
|
|
|
88290
|
for my $sc_name (keys %{ $cd->{metas} }) { |
1329
|
100
|
100
|
|
|
|
1062
|
my $meta = $cd->{metas}{$sc_name}; |
1330
|
50
|
|
|
|
|
18120
|
my $args_as = $meta->{args_as} // 'hash'; |
1331
|
|
|
|
|
|
|
if ($args_as !~ /\A(hashref|hash)\z/) { |
1332
|
50
|
|
|
|
|
82381
|
return [501, "args_as=$args_as currently unsupported at subcommand='$sc_name'"]; |
1333
|
|
|
|
|
|
|
} |
1334
|
|
|
|
|
|
|
$args_as{$sc_name} = $args_as; |
1335
|
|
|
|
|
|
|
|
1336
|
50
|
|
|
|
|
126
|
my $ggl_res = Perinci::Sub::GetArgs::Argv::gen_getopt_long_spec_from_meta( |
|
50
|
|
|
|
|
293
|
|
|
50
|
|
|
|
|
1445
|
|
1337
|
50
|
|
|
|
|
19049
|
meta => $meta, |
1338
|
|
|
|
|
|
|
meta_is_normalized => 1, |
1339
|
50
|
|
|
|
|
131
|
per_arg_json => 1, |
|
50
|
|
|
|
|
240
|
|
1340
|
55
|
|
|
|
|
152
|
common_opts => $cd->{copts}, |
1341
|
55
|
|
100
|
|
|
848
|
); |
1342
|
55
|
100
|
|
|
|
494
|
return [500, "Can't generate Getopt::Long spec from meta (subcommand='$sc_name'): ". |
1343
|
2
|
|
|
|
|
71
|
"$ggl_res->[0] - $ggl_res->[1]"] |
1344
|
|
|
|
|
|
|
unless $ggl_res->[0] == 200; |
1345
|
53
|
|
|
|
|
230
|
$ggl_res{$sc_name} = $ggl_res; |
1346
|
|
|
|
|
|
|
} |
1347
|
|
|
|
|
|
|
$cd->{ggl_res} = \%ggl_res; |
1348
|
|
|
|
|
|
|
$cd->{args_as} = \%args_as; |
1349
|
|
|
|
|
|
|
_gen_pci_check_args($cd); |
1350
|
|
|
|
|
|
|
} |
1351
|
|
|
|
|
|
|
|
1352
|
53
|
|
|
|
|
595
|
$cd->{vars}{'$_pci_r'} = { |
1353
|
53
|
50
|
|
|
|
85967
|
naked_res => 0, |
1354
|
|
|
|
|
|
|
subcommand_name => '', |
1355
|
|
|
|
|
|
|
read_config => $args{read_config}, |
1356
|
53
|
|
|
|
|
222
|
read_env => $args{read_env}, |
1357
|
|
|
|
|
|
|
}; |
1358
|
48
|
|
|
|
|
279
|
|
1359
|
48
|
|
|
|
|
353
|
$cd->{vars}{'%_pci_args'} = undef; |
1360
|
48
|
|
|
|
|
397
|
push @l, "### get arguments (from config file, env, command-line args\n\n"; |
1361
|
|
|
|
|
|
|
push @l, "{\n", _gen_get_args($cd), "}\n\n"; |
1362
|
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
|
# gen code to check arguments |
1364
|
|
|
|
|
|
|
push @l, "### check arguments\n\n"; |
1365
|
|
|
|
|
|
|
push @l, "{\n"; |
1366
|
|
|
|
|
|
|
push @l, 'require Local::_pci_check_args; ' if $cd->{gen_args}{pack_deps}; |
1367
|
|
|
|
|
|
|
push @l, 'my $res = _pci_check_args(\\%_pci_args);', "\n"; |
1368
|
48
|
|
|
|
|
594
|
push @l, '_pci_debug("args after _pci_check_args: ", \%_pci_args);', "\n" if $cd->{gen_args}{with_debug}; |
1369
|
|
|
|
|
|
|
push @l, '_pci_err($res) if $res->[0] != 200;', "\n"; |
1370
|
48
|
|
|
|
|
337
|
push @l, '$_pci_r->{args} = \\%_pci_args;', "\n"; |
1371
|
48
|
|
|
|
|
333
|
push @l, "}\n\n"; |
1372
|
48
|
|
|
|
|
572
|
|
1373
|
|
|
|
|
|
|
# generate code to call function |
1374
|
|
|
|
|
|
|
push @l, "### call function\n\n"; |
1375
|
48
|
|
|
|
|
139
|
$cd->{vars}{'$_pci_meta_result_stream'} = 0; |
1376
|
48
|
|
|
|
|
107
|
$cd->{vars}{'$_pci_meta_skip_format'} = 0; |
1377
|
48
|
50
|
|
|
|
223
|
$cd->{vars}{'$_pci_meta_result_type'} = undef; |
1378
|
48
|
|
|
|
|
156
|
$cd->{vars}{'$_pci_meta_result_type_is_simple'} = undef; |
1379
|
48
|
50
|
|
|
|
160
|
push @l, "{\n"; |
1380
|
48
|
|
|
|
|
169
|
push @l, 'log_trace("Calling function ...");', "\n" if $cd->{gen_args}{log}; |
1381
|
48
|
|
|
|
|
236
|
push @l, 'my $sc_name = $_pci_r->{subcommand_name};' . "\n"; |
1382
|
48
|
|
|
|
|
142
|
push @l, '$_pci_args{-cmdline} = Perinci::CmdLine::Inline::Object->new(@{', dmp([%args]), '});', "\n" |
1383
|
|
|
|
|
|
|
if $args{pass_cmdline_object}; |
1384
|
|
|
|
|
|
|
{ |
1385
|
48
|
|
|
|
|
95
|
my $i = -1; |
1386
|
48
|
|
|
|
|
156
|
for my $sc_name (sort keys %{ $cd->{metas} }) { |
1387
|
48
|
|
|
|
|
133
|
$i++; |
1388
|
48
|
|
|
|
|
151
|
my $meta = $cd->{metas}{$sc_name}; |
1389
|
48
|
|
|
|
|
122
|
push @l, ($i ? 'elsif' : 'if').' ($sc_name eq '.dmp($sc_name).") {\n"; |
1390
|
48
|
|
|
|
|
97
|
push @l, ' $_pci_meta_result_stream = 1;'."\n" if $meta->{result}{stream}; |
1391
|
48
|
100
|
|
|
|
171
|
push @l, ' $_pci_meta_skip_format = 1;'."\n" if $meta->{'cmdline.skip_format'}; |
1392
|
48
|
|
|
|
|
105
|
push @l, ' $_pci_meta_result_type = '.dmp(Data::Sah::Util::Type::get_type($meta->{result}{schema} // '') // '').";\n"; |
1393
|
|
|
|
|
|
|
push @l, ' $_pci_meta_result_type_is_simple = 1;'."\n" if Data::Sah::Util::Type::is_simple($meta->{result}{schema} // ''); |
1394
|
48
|
50
|
|
|
|
209
|
push @l, " require $cd->{sc_mods}{$sc_name};\n" if $cd->{sc_mods}{$sc_name}; |
1395
|
|
|
|
|
|
|
push @l, ' eval { $_pci_r->{res} = ', $cd->{func_names}{$sc_name}, ($cd->{args_as}{$sc_name} eq 'hashref' ? '(\\%_pci_args)' : '(%_pci_args)'), ' };', "\n"; |
1396
|
48
|
|
|
|
|
95
|
push @l, ' if ($@) { die if $ENV{PERINCI_CMDLINE_INLINE_DEBUG_DIE}; $_pci_r->{res} = [500, "Function died: $@"] }', "\n"; |
|
48
|
|
|
|
|
246
|
|
1397
|
48
|
|
|
|
|
161
|
if ($meta->{result_naked}) { |
|
48
|
|
|
|
|
246
|
|
1398
|
53
|
|
|
|
|
90
|
push @l, ' $_pci_r->{res} = [200, "OK (envelope added by Perinci::CmdLine::Inline)", $_pci_r->{res}];', "\n"; |
1399
|
53
|
|
|
|
|
143
|
} |
1400
|
53
|
100
|
|
|
|
315
|
push @l, "}\n"; |
1401
|
53
|
100
|
|
|
|
1723
|
} |
1402
|
53
|
50
|
|
|
|
182
|
} |
1403
|
53
|
|
100
|
|
|
573
|
push @l, "}\n\n"; |
|
|
|
50
|
|
|
|
|
1404
|
53
|
100
|
100
|
|
|
2246
|
|
1405
|
53
|
50
|
|
|
|
1247
|
# generate code to format & display result |
1406
|
53
|
100
|
|
|
|
686
|
push @l, "### format & display result\n\n"; |
1407
|
53
|
|
|
|
|
406
|
push @l, "{\n"; |
1408
|
53
|
100
|
|
|
|
209
|
push @l, 'log_trace("Displaying result ...");', "\n" if $cd->{gen_args}{log}; |
1409
|
1
|
|
|
|
|
15
|
|
1410
|
|
|
|
|
|
|
push @l, 'my $fh;', "\n"; |
1411
|
53
|
|
|
|
|
333
|
push @l, 'if ($_pci_r->{page_result} // $ENV{PAGE_RESULT} // $_pci_r->{res}[3]{"cmdline.page_result"}) {', "\n"; |
1412
|
|
|
|
|
|
|
push @l, 'my $pager = $_pci_r->{pager} // $_pci_r->{res}[3]{"cmdline.pager"} // $ENV{PAGER} // "less -FRSX";', "\n"; |
1413
|
|
|
|
|
|
|
push @l, 'open $fh, "| $pager"; ## no critic InputOutput::ProhibitTwoArgOpen', "\n"; |
1414
|
48
|
|
|
|
|
177
|
push @l, '} else {', "\n"; |
1415
|
|
|
|
|
|
|
push @l, '$fh = \*STDOUT;', "\n"; |
1416
|
|
|
|
|
|
|
push @l, '}', "\n"; |
1417
|
48
|
|
|
|
|
95
|
|
1418
|
48
|
|
|
|
|
92
|
push @l, 'my $fres;', "\n"; |
1419
|
48
|
100
|
|
|
|
331
|
push @l, 'my $save_res; if (exists $_pci_r->{res}[3]{"cmdline.result"}) { $save_res = $_pci_r->{res}[2]; $_pci_r->{res}[2] = $_pci_r->{res}[3]{"cmdline.result"} }', "\n"; |
1420
|
|
|
|
|
|
|
push @l, 'my $is_success = $_pci_r->{res}[0] =~ /\A2/ || $_pci_r->{res}[0] == 304;', "\n"; |
1421
|
48
|
|
|
|
|
407
|
push @l, 'my $is_stream = $_pci_r->{res}[3]{stream} // $_pci_meta_result_stream // 0;'."\n"; |
1422
|
48
|
|
|
|
|
162
|
push @l, 'if ($is_success && (', ($args{skip_format} ? 1:0), ' || $_pci_meta_skip_format || $_pci_r->{res}[3]{"cmdline.skip_format"})) { $fres = $_pci_r->{res}[2] }', "\n"; |
1423
|
48
|
|
|
|
|
121
|
push @l, 'elsif ($is_success && $is_stream) {}', "\n"; |
1424
|
48
|
|
|
|
|
376
|
push @l, 'else { '; |
1425
|
48
|
|
|
|
|
290
|
push @l, 'require Local::_pci_clean_json; ' if $args{pack_deps} && $args{use_cleanser}; |
1426
|
48
|
|
|
|
|
211
|
push @l, 'require Perinci::Result::Format::Lite; $is_stream=0; '; |
1427
|
48
|
|
|
|
|
125
|
push @l, '_pci_clean_json($_pci_r->{res}); ' if $args{use_cleanser}; |
1428
|
|
|
|
|
|
|
push @l, '$fres = Perinci::Result::Format::Lite::format($_pci_r->{res}, ($_pci_r->{format} // $_pci_r->{res}[3]{"cmdline.default_format"} // "text"), $_pci_r->{naked_res}, 0) }', "\n"; |
1429
|
48
|
|
|
|
|
136
|
push @l, "\n"; |
1430
|
48
|
|
|
|
|
260
|
|
1431
|
48
|
|
|
|
|
155
|
push @l, 'my $use_utf8 = $_pci_r->{res}[3]{"x.hint.result_binary"} ? 0 : '.($args{use_utf8} ? 1:0).";\n"; |
1432
|
48
|
|
|
|
|
122
|
push @l, 'if ($use_utf8) { binmode STDOUT, ":encoding(utf8)" }', "\n"; |
1433
|
48
|
50
|
|
|
|
254
|
|
1434
|
48
|
|
|
|
|
365
|
push @l, 'if ($is_stream) {', "\n"; |
1435
|
48
|
|
|
|
|
104
|
push @l, ' my $code = $_pci_r->{res}[2]; if (ref($code) ne "CODE") { die "Result is a stream but no coderef provided" } if ($_pci_meta_result_type_is_simple) { while(defined(my $l=$code->())) { print $fh $l; print $fh "\n" unless $_pci_meta_result_type eq "buf"; } } else { while (defined(my $rec=$code->())) { if (!defined($rec) || ref $rec) { print $fh _pci_json()->encode($rec),"\n" } else { print $fh $rec,"\n" } } }', "\n"; |
1436
|
48
|
50
|
33
|
|
|
541
|
push @l, '} else {', "\n"; |
1437
|
48
|
|
|
|
|
243
|
push @l, ' print $fh $fres;', "\n"; |
1438
|
48
|
50
|
|
|
|
335
|
push @l, '}', "\n"; |
1439
|
48
|
|
|
|
|
310
|
push @l, 'if (defined $save_res) { $_pci_r->{res}[2] = $save_res }', "\n"; |
1440
|
48
|
|
|
|
|
276
|
push @l, "}\n\n"; |
1441
|
|
|
|
|
|
|
|
1442
|
48
|
50
|
|
|
|
447
|
# generate code to exit with code |
1443
|
48
|
|
|
|
|
300
|
push @l, "### exit\n\n"; |
1444
|
|
|
|
|
|
|
push @l, "{\n"; |
1445
|
48
|
|
|
|
|
313
|
push @l, 'my $status = $_pci_r->{res}[0];', "\n"; |
1446
|
48
|
|
|
|
|
287
|
push @l, 'my $exit_code = $_pci_r->{res}[3]{"cmdline.exit_code"} // ($status =~ /200|304/ ? 0 : ($status-300));', "\n"; |
1447
|
48
|
|
|
|
|
343
|
push @l, 'exit($exit_code);', "\n"; |
1448
|
48
|
|
|
|
|
169
|
push @l, "}\n\n"; |
1449
|
48
|
|
|
|
|
95
|
|
1450
|
48
|
|
|
|
|
265
|
# remove unneeded modules |
1451
|
48
|
|
|
|
|
108
|
if ($args{skip_format}) { |
1452
|
|
|
|
|
|
|
delete $cd->{module_srcs}{'Data::Check::Structure'}; |
1453
|
|
|
|
|
|
|
delete $cd->{module_srcs}{'Perinci::Result::Format::Lite'}; |
1454
|
48
|
|
|
|
|
83
|
delete $cd->{module_srcs}{'Text::Table::Sprintf'}; |
1455
|
48
|
|
|
|
|
91
|
} |
1456
|
48
|
|
|
|
|
112
|
|
1457
|
48
|
|
|
|
|
108
|
if ($args{pass_cmdline_object}) { |
1458
|
48
|
|
|
|
|
217
|
require Class::GenSource; |
1459
|
48
|
|
|
|
|
150
|
my $cl = 'Perinci::CmdLine::Inline::Object'; |
1460
|
|
|
|
|
|
|
$cd->{module_srcs}{$cl} = |
1461
|
|
|
|
|
|
|
Class::GenSource::gen_class_source_code( |
1462
|
48
|
50
|
|
|
|
157
|
name => $cl, |
1463
|
0
|
|
|
|
|
0
|
attributes => { |
1464
|
0
|
|
|
|
|
0
|
map { $_ => {} } keys %pericmd_attrs, |
1465
|
0
|
|
|
|
|
0
|
}, |
1466
|
|
|
|
|
|
|
); |
1467
|
|
|
|
|
|
|
} |
1468
|
48
|
50
|
|
|
|
170
|
|
1469
|
0
|
|
|
|
|
0
|
my ($dp_code1, $dp_code2, $dp_code3); |
1470
|
0
|
|
|
|
|
0
|
if ($args{pack_deps}) { |
1471
|
|
|
|
|
|
|
require Module::DataPack; |
1472
|
|
|
|
|
|
|
my $dp_res = Module::DataPack::datapack_modules( |
1473
|
|
|
|
|
|
|
module_srcs => $cd->{module_srcs}, |
1474
|
|
|
|
|
|
|
stripper => $args{stripper}, |
1475
|
0
|
|
|
|
|
0
|
); |
|
0
|
|
|
|
|
0
|
|
1476
|
|
|
|
|
|
|
return [500, "Can't datapack: $dp_res->[0] - $dp_res->[1]"] |
1477
|
|
|
|
|
|
|
unless $dp_res->[0] == 200; |
1478
|
|
|
|
|
|
|
$dp_code2 = ""; |
1479
|
|
|
|
|
|
|
($dp_code1, $dp_code3) = $dp_res->[2] =~ /(.+?)^(__DATA__\n.+)/sm; |
1480
|
48
|
|
|
|
|
258
|
} else { |
1481
|
48
|
50
|
|
|
|
161
|
$dp_code1 = ""; |
1482
|
48
|
|
|
|
|
1193
|
$dp_code2 = ""; |
1483
|
|
|
|
|
|
|
$dp_code3 = ""; |
1484
|
|
|
|
|
|
|
for my $pkg (sort keys %{ $cd->{module_srcs} }) { |
1485
|
|
|
|
|
|
|
my $src = $cd->{module_srcs}{$pkg}; |
1486
|
48
|
|
|
|
|
4708
|
$dp_code2 .= "# BEGIN $pkg\n$src\n# END $pkg\n\n"; |
1487
|
48
|
50
|
|
|
|
251755
|
} |
1488
|
|
|
|
|
|
|
} |
1489
|
48
|
|
|
|
|
136
|
|
1490
|
48
|
|
|
|
|
16352
|
my $pod; |
1491
|
|
|
|
|
|
|
if ($args{pod} // 1) { |
1492
|
0
|
|
|
|
|
0
|
require Perinci::CmdLine::POD; |
1493
|
0
|
|
|
|
|
0
|
my $res = Perinci::CmdLine::POD::gen_pod_for_pericmd_script( |
1494
|
0
|
|
|
|
|
0
|
url => $args{url}, |
1495
|
0
|
|
|
|
|
0
|
program_name => $cd->{script_name}, |
|
0
|
|
|
|
|
0
|
|
1496
|
0
|
|
|
|
|
0
|
summary => $args{script_summary}, |
1497
|
0
|
|
|
|
|
0
|
common_opts => $cd->{copts}, |
1498
|
|
|
|
|
|
|
subcommands => $args{subcommands}, |
1499
|
|
|
|
|
|
|
default_subcommand => $args{default_subcommand}, |
1500
|
|
|
|
|
|
|
per_arg_json => 1, |
1501
|
48
|
|
|
|
|
202
|
per_arg_yaml => 0, |
1502
|
48
|
50
|
50
|
|
|
270
|
read_env => $args{read_env}, |
1503
|
48
|
|
|
|
|
2127
|
env_name => $args{env_name}, |
1504
|
|
|
|
|
|
|
read_config => $args{read_config}, |
1505
|
|
|
|
|
|
|
config_filename => $args{config_filenames}, |
1506
|
|
|
|
|
|
|
config_dirs => $args{config_dirs}, |
1507
|
|
|
|
|
|
|
completer_script => "_$cd->{script_name}", |
1508
|
|
|
|
|
|
|
); |
1509
|
|
|
|
|
|
|
return err($res, 500, "Can't generate POD") unless $res->[0] == 200; |
1510
|
|
|
|
|
|
|
$pod = $res->[2]; |
1511
|
|
|
|
|
|
|
} |
1512
|
|
|
|
|
|
|
|
1513
|
|
|
|
|
|
|
# generate final result |
1514
|
|
|
|
|
|
|
$cd->{result} = join( |
1515
|
|
|
|
|
|
|
"", |
1516
|
|
|
|
|
|
|
$shebang_line, "\n", |
1517
|
|
|
|
|
|
|
|
1518
|
48
|
|
|
|
|
20910
|
"### begin code_after_shebang\n", |
1519
|
|
|
|
|
|
|
($args{code_after_shebang}, "\n") x !!$args{code_after_shebang}, |
1520
|
48
|
50
|
|
|
|
573377
|
"### end code_after_shebang\n", |
1521
|
48
|
|
|
|
|
507
|
|
1522
|
|
|
|
|
|
|
"# PERICMD_INLINE_SCRIPT: ", do { |
1523
|
|
|
|
|
|
|
my %tmp = %args; |
1524
|
|
|
|
|
|
|
# don't show the potentially long/undumpable argument values |
1525
|
|
|
|
|
|
|
for (grep {/^code_/} keys %tmp) { |
1526
|
|
|
|
|
|
|
$tmp{$_} = "..."; |
1527
|
|
|
|
|
|
|
} |
1528
|
|
|
|
|
|
|
JSON::MaybeXS->new->canonical(1)->encode(\%tmp); |
1529
|
|
|
|
|
|
|
}, "\n\n", |
1530
|
|
|
|
|
|
|
|
1531
|
|
|
|
|
|
|
"# This script is generated by ", __PACKAGE__, |
1532
|
|
|
|
|
|
|
" version ", (${__PACKAGE__."::VERSION"} // 'dev'), " on ", |
1533
|
|
|
|
|
|
|
scalar(localtime), ".\n\n", |
1534
|
48
|
|
|
|
|
723
|
|
1535
|
|
|
|
|
|
|
(keys %{$cd->{mods}} ? "# Rinci metadata taken from these modules: ".join(", ", map {"$_ ".($cd->{mods}{$_}{version} // "(no version)")} sort keys %{$cd->{mods}})."\n\n" : ""), |
1536
|
48
|
|
|
|
|
289
|
|
|
915
|
|
|
|
|
1742
|
|
1537
|
48
|
|
|
|
|
289
|
"# You probably should not manually edit this file.\n\n", |
1538
|
|
|
|
|
|
|
|
1539
|
48
|
|
|
|
|
1327
|
"## no critic: TestingAndDebugging::RequireUseStrict\n\n", # fatpack/datapack code is not using strict currently |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
# for dzil |
1542
|
|
|
|
|
|
|
"# PODNAME: ", ($args{script_name} // ''), "\n", |
1543
|
48
|
|
|
|
|
5228
|
do { |
1544
|
|
|
|
|
|
|
my $abstract = $args{script_summary} // $cd->{metas}{''}{summary}; |
1545
|
|
|
|
|
|
|
if ($abstract) { |
1546
|
48
|
|
50
|
|
|
402
|
("# ABSTRACT: ", $abstract, "\n"); |
|
48
|
|
|
|
|
999
|
|
|
48
|
|
|
|
|
179
|
|
1547
|
|
|
|
|
|
|
} else { |
1548
|
|
|
|
|
|
|
(); |
1549
|
|
|
|
|
|
|
} |
1550
|
|
|
|
|
|
|
}, |
1551
|
|
|
|
|
|
|
"\n", |
1552
|
|
|
|
|
|
|
|
1553
|
|
|
|
|
|
|
$dp_code1, |
1554
|
|
|
|
|
|
|
|
1555
|
48
|
|
66
|
|
|
575
|
"package main;\n", |
1556
|
48
|
100
|
|
|
|
176
|
"use 5.010001;\n", |
1557
|
38
|
|
|
|
|
342
|
"use strict;\n", |
1558
|
|
|
|
|
|
|
"#use warnings;\n\n", |
1559
|
10
|
|
|
|
|
33
|
|
1560
|
|
|
|
|
|
|
"# load modules\n", |
1561
|
|
|
|
|
|
|
(map {"require $_;\n"} sort keys %{$cd->{req_modules}}), |
1562
|
|
|
|
|
|
|
"\n", |
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
"\n", |
1565
|
|
|
|
|
|
|
|
1566
|
|
|
|
|
|
|
"### declare global variables\n\n", |
1567
|
|
|
|
|
|
|
# for dzil |
1568
|
|
|
|
|
|
|
"# AUTHORITY\n", |
1569
|
|
|
|
|
|
|
"# DATE\n", |
1570
|
|
|
|
|
|
|
"# DIST\n", |
1571
|
|
|
|
|
|
|
"# VERSION\n", |
1572
|
0
|
|
|
|
|
0
|
"\n", |
|
48
|
|
|
|
|
234
|
|
1573
|
|
|
|
|
|
|
'my $_pci_metas = ', do { |
1574
|
|
|
|
|
|
|
local $Data::Dmp::OPT_DEPARSE=0; |
1575
|
|
|
|
|
|
|
dmp($cd->{metas}); |
1576
|
|
|
|
|
|
|
}, ";\n\n", |
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
(map { "our $_" . (defined($cd->{vars}{$_}) ? " = ".dmp($cd->{vars}{$_}) : "").";\n" } sort keys %{$cd->{vars}}), |
1579
|
|
|
|
|
|
|
(keys(%{$cd->{vars}}) ? "\n" : ""), |
1580
|
|
|
|
|
|
|
|
1581
|
|
|
|
|
|
|
$args{log} ? _gen_enable_log($cd) : '', |
1582
|
|
|
|
|
|
|
|
1583
|
|
|
|
|
|
|
"### declare subroutines\n\n", |
1584
|
|
|
|
|
|
|
(map { |
1585
|
48
|
|
|
|
|
112
|
my $sub = $_; |
1586
|
48
|
|
|
|
|
186
|
if ($cd->{sub_src_core_deps}{$sub}) { |
1587
|
|
|
|
|
|
|
for my $mod (keys %{ $cd->{sub_src_core_deps}{$sub} }) { |
1588
|
|
|
|
|
|
|
$cd->{core_deps}{$mod} //= |
1589
|
289
|
100
|
|
|
|
7835
|
$cd->{sub_src_core_deps}{$sub}{$mod}; |
|
48
|
|
|
|
|
25351
|
|
1590
|
48
|
|
|
|
|
468
|
} |
1591
|
|
|
|
|
|
|
} |
1592
|
|
|
|
|
|
|
"sub $sub" . (ref($cd->{sub_srcs}{$sub}) eq 'ARRAY' ? |
1593
|
|
|
|
|
|
|
"($cd->{sub_srcs}{$sub}[0]) {\n$cd->{sub_srcs}{$sub}[1]}\n\n" : " {\n$cd->{sub_srcs}{$sub}}\n\n")} |
1594
|
|
|
|
|
|
|
sort keys %{$cd->{sub_srcs}}), |
1595
|
|
|
|
|
|
|
|
1596
|
100
|
|
|
|
|
185
|
"### begin code_before_parse_cmdline_options\n", |
1597
|
100
|
100
|
|
|
|
315
|
($args{code_before_parse_cmdline_options}, "\n") x !!$args{code_before_parse_cmdline_options}, |
1598
|
48
|
|
|
|
|
119
|
"### end code_before_parse_cmdline_options\n", |
|
48
|
|
|
|
|
392
|
|
1599
|
|
|
|
|
|
|
|
1600
|
48
|
|
33
|
|
|
578
|
@l, |
1601
|
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
|
$dp_code2, |
1603
|
100
|
50
|
|
|
|
15828
|
|
1604
|
|
|
|
|
|
|
defined $pod ? ("=pod\n\n", "=encoding UTF-8\n\n", $pod, "\n\n=cut\n\n") : (), |
1605
|
48
|
|
|
|
|
282
|
|
1606
|
|
|
|
|
|
|
$dp_code3, |
1607
|
|
|
|
|
|
|
|
1608
|
|
|
|
|
|
|
"### begin code_after_end\n", |
1609
|
|
|
|
|
|
|
($args{code_after_end}, "\n") x !!$args{code_after_end}, |
1610
|
|
|
|
|
|
|
"### end code_after_end\n", |
1611
|
|
|
|
|
|
|
); |
1612
|
|
|
|
|
|
|
} |
1613
|
|
|
|
|
|
|
|
1614
|
|
|
|
|
|
|
WRITE_OUTPUT: |
1615
|
|
|
|
|
|
|
{ |
1616
|
|
|
|
|
|
|
my ($fh, $output_is_stdout); |
1617
|
|
|
|
|
|
|
if (!defined($args{output_file}) || $args{output_file} eq '-') { |
1618
|
|
|
|
|
|
|
$output_is_stdout++; |
1619
|
|
|
|
|
|
|
} else { |
1620
|
|
|
|
|
|
|
if (-f $args{output_file}) { |
1621
|
48
|
50
|
50
|
|
|
467
|
return [412, "Output file '$args{output_file}' exists, ". |
|
|
50
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
"won't overwrite (see --overwrite)"] |
1623
|
|
|
|
|
|
|
unless $args{overwrite}; |
1624
|
|
|
|
|
|
|
} |
1625
|
|
|
|
|
|
|
open $fh, ">", $args{output_file} |
1626
|
|
|
|
|
|
|
or return [500, "Can't open $args{output_file}: $!"]; |
1627
|
48
|
|
|
|
|
327
|
} |
|
48
|
|
|
|
|
191
|
|
1628
|
48
|
50
|
33
|
|
|
265
|
|
1629
|
48
|
|
|
|
|
102
|
if ($output_is_stdout) { |
1630
|
|
|
|
|
|
|
return [200, "OK", $cd->{result}, { |
1631
|
0
|
0
|
|
|
|
0
|
'func.raw_result' => $cd, |
1632
|
|
|
|
|
|
|
}]; |
1633
|
|
|
|
|
|
|
} else { |
1634
|
0
|
0
|
|
|
|
0
|
print $fh $cd->{result}; |
1635
|
|
|
|
|
|
|
close $fh or return [500, "Can't write $args{output_file}: $!"]; |
1636
|
|
|
|
|
|
|
chmod 0755, $args{output_file} or do { |
1637
|
0
|
0
|
|
|
|
0
|
warn "Can't chmod 755 $args{output_file}: $!"; |
1638
|
|
|
|
|
|
|
}; |
1639
|
|
|
|
|
|
|
return [200, "OK", undef, { |
1640
|
48
|
50
|
|
|
|
122
|
'func.raw_result'=>$cd, |
1641
|
|
|
|
|
|
|
}]; |
1642
|
48
|
|
|
|
|
664
|
} |
1643
|
|
|
|
|
|
|
} |
1644
|
|
|
|
|
|
|
} |
1645
|
0
|
|
|
|
|
|
|
1646
|
0
|
0
|
|
|
|
|
1; |
1647
|
0
|
0
|
|
|
|
|
# ABSTRACT: Generate inline Perinci::CmdLine CLI script |
1648
|
0
|
|
|
|
|
|
|
1649
|
|
|
|
|
|
|
|
1650
|
0
|
|
|
|
|
|
=pod |
1651
|
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
|
=encoding UTF-8 |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
=head1 NAME |
1655
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
Perinci::CmdLine::Inline - Generate inline Perinci::CmdLine CLI script |
1657
|
|
|
|
|
|
|
|
1658
|
|
|
|
|
|
|
=head1 VERSION |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
This document describes version 0.554 of Perinci::CmdLine::Inline (from Perl distribution Perinci-CmdLine-Inline), released on 2022-01-16. |
1661
|
|
|
|
|
|
|
|
1662
|
|
|
|
|
|
|
=head1 SYNOPSIS |
1663
|
|
|
|
|
|
|
|
1664
|
|
|
|
|
|
|
% gen-inline-pericmd-script /Perinci/Examples/gen_array -o gen-array |
1665
|
|
|
|
|
|
|
|
1666
|
|
|
|
|
|
|
% ./gen-array |
1667
|
|
|
|
|
|
|
ERROR 400: Missing required argument(s): len |
1668
|
|
|
|
|
|
|
|
1669
|
|
|
|
|
|
|
% ./gen-array --help |
1670
|
|
|
|
|
|
|
... help message printed ... |
1671
|
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
|
% ./gen-array 3 |
1673
|
|
|
|
|
|
|
2 |
1674
|
|
|
|
|
|
|
3 |
1675
|
|
|
|
|
|
|
1 |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
% ./gen-array 3 --json |
1678
|
|
|
|
|
|
|
[200,"OK",[3,1,2],{}] |
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
=head1 DESCRIPTION |
1681
|
|
|
|
|
|
|
|
1682
|
|
|
|
|
|
|
=head1 COMPILATION DATA KEYS |
1683
|
|
|
|
|
|
|
|
1684
|
|
|
|
|
|
|
A hash structure, C<$cd>, is constructed and passed around between routines |
1685
|
|
|
|
|
|
|
during the generation process. It contains the following keys: |
1686
|
|
|
|
|
|
|
|
1687
|
|
|
|
|
|
|
=over |
1688
|
|
|
|
|
|
|
|
1689
|
|
|
|
|
|
|
=item * module_srcs => hash |
1690
|
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
|
Generated script's module source codes. To reduce startup overhead and |
1692
|
|
|
|
|
|
|
dependency, these modules' source codes are included in the generated script |
1693
|
|
|
|
|
|
|
using the datapack technique (see L<Module::DataPack>). |
1694
|
|
|
|
|
|
|
|
1695
|
|
|
|
|
|
|
Among the modules are L<Getopt::Long::EvenLess> to parse command-line options, |
1696
|
|
|
|
|
|
|
L<Text::Table::Sprintf> to produce text table output, and also a few generated |
1697
|
|
|
|
|
|
|
modules to modularize the generated script's structure. |
1698
|
|
|
|
|
|
|
|
1699
|
|
|
|
|
|
|
=item * vars => hash |
1700
|
|
|
|
|
|
|
|
1701
|
|
|
|
|
|
|
Generated script's global variables. Keys are variable names (including the |
1702
|
|
|
|
|
|
|
sigils) and values are initial variable values (undef means unitialized). |
1703
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
=item * sub_srcs => hash |
1705
|
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
|
Generated script's subroutine source codes. Keys are subroutines' names and |
1707
|
|
|
|
|
|
|
values are subroutines' source codes. |
1708
|
|
|
|
|
|
|
|
1709
|
|
|
|
|
|
|
=back |
1710
|
|
|
|
|
|
|
|
1711
|
|
|
|
|
|
|
=head1 ENVIRONMENT (GENERATED SCRIPTS) |
1712
|
|
|
|
|
|
|
|
1713
|
|
|
|
|
|
|
These are environment variables observed by the generated scripts. |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
=head2 PERINCI_CMDLINE_INLINE_DEBUG_DIE |
1716
|
|
|
|
|
|
|
|
1717
|
|
|
|
|
|
|
Bool. If set to true, then will rethrow exception instead of converting it into |
1718
|
|
|
|
|
|
|
enveloped result. This makes debugging easier. |
1719
|
|
|
|
|
|
|
|
1720
|
|
|
|
|
|
|
=head1 FUNCTIONS |
1721
|
|
|
|
|
|
|
|
1722
|
|
|
|
|
|
|
|
1723
|
|
|
|
|
|
|
=head2 gen_inline_pericmd_script |
1724
|
|
|
|
|
|
|
|
1725
|
|
|
|
|
|
|
Usage: |
1726
|
|
|
|
|
|
|
|
1727
|
|
|
|
|
|
|
gen_inline_pericmd_script(%args) -> [$status_code, $reason, $payload, \%result_meta] |
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
Generate inline Perinci::CmdLine CLI script. |
1730
|
|
|
|
|
|
|
|
1731
|
|
|
|
|
|
|
The goal of this module is to let you create a CLI script from a Riap |
1732
|
|
|
|
|
|
|
function/metadata. This is like what L<Perinci::CmdLine::Lite> or |
1733
|
|
|
|
|
|
|
L<Perinci::CmdLine::Classic> does, except that the generated CLI script will have |
1734
|
|
|
|
|
|
|
the functionalities inlined so it only need core Perl modules and not any of the |
1735
|
|
|
|
|
|
|
C<Perinci::CmdLine::*> or other modules to run (excluding what modules the Riap |
1736
|
|
|
|
|
|
|
function itself requires). |
1737
|
|
|
|
|
|
|
|
1738
|
|
|
|
|
|
|
It's useful if you want a CLI script that is even more lightweight (in terms of |
1739
|
|
|
|
|
|
|
startup overhead or dependencies) than the one using L<Perinci::CmdLine::Lite>. |
1740
|
|
|
|
|
|
|
|
1741
|
|
|
|
|
|
|
So to reiterate, the goal of this module is to create a Perinci::CmdLine-based |
1742
|
|
|
|
|
|
|
script which only requires core modules, and has as little startup overhead as |
1743
|
|
|
|
|
|
|
possible. |
1744
|
|
|
|
|
|
|
|
1745
|
|
|
|
|
|
|
Currently it only supports a subset of features compared to other |
1746
|
|
|
|
|
|
|
C<Perinci::CmdLine::*> implementations: |
1747
|
|
|
|
|
|
|
|
1748
|
|
|
|
|
|
|
=over |
1749
|
|
|
|
|
|
|
|
1750
|
|
|
|
|
|
|
=item * Only support local Riap URL (e.g. C</Foo/bar>, not |
1751
|
|
|
|
|
|
|
CLL<http://example.org/Foo/bar>); |
1752
|
|
|
|
|
|
|
|
1753
|
|
|
|
|
|
|
=back |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
As an alternative to this module, if you are looking to reduce dependencies, you |
1756
|
|
|
|
|
|
|
might also want to try using C<depak> to fatpack/datapack your |
1757
|
|
|
|
|
|
|
L<Perinci::CmdLine::Lite>-based script. |
1758
|
|
|
|
|
|
|
|
1759
|
|
|
|
|
|
|
This function is not exported by default, but exportable. |
1760
|
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
|
Arguments ('*' denotes required arguments): |
1762
|
|
|
|
|
|
|
|
1763
|
|
|
|
|
|
|
=over 4 |
1764
|
|
|
|
|
|
|
|
1765
|
|
|
|
|
|
|
=item * B<actions> => I<any> |
1766
|
|
|
|
|
|
|
|
1767
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1768
|
|
|
|
|
|
|
|
1769
|
|
|
|
|
|
|
=item * B<allow_prereq> => I<array[str]> |
1770
|
|
|
|
|
|
|
|
1771
|
|
|
|
|
|
|
A list of modules that can be depended upon. |
1772
|
|
|
|
|
|
|
|
1773
|
|
|
|
|
|
|
By default, Perinci::CmdLine::Inline will strive to make the script freestanding |
1774
|
|
|
|
|
|
|
and require only core Perl modules. A dependency to a non-core module will cause |
1775
|
|
|
|
|
|
|
failure (unless C<pack_deps> option is set to false). However, you can pass a |
1776
|
|
|
|
|
|
|
list of modules that is allowed here. |
1777
|
|
|
|
|
|
|
|
1778
|
|
|
|
|
|
|
=item * B<code_add_extra_log_outputs> => I<str> |
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
=item * B<code_after_enable_logging> => I<str> |
1781
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
=item * B<code_after_end> => I<str> |
1783
|
|
|
|
|
|
|
|
1784
|
|
|
|
|
|
|
Put at the very end of generated script. |
1785
|
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
=item * B<code_after_shebang> => I<str> |
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
Put at the very beginning of generated script, after the shebang line. |
1789
|
|
|
|
|
|
|
|
1790
|
|
|
|
|
|
|
=item * B<code_before_enable_logging> => I<str> |
1791
|
|
|
|
|
|
|
|
1792
|
|
|
|
|
|
|
=item * B<code_before_parse_cmdline_options> => I<str> |
1793
|
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
|
=item * B<common_opts> => I<any> |
1795
|
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1797
|
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
|
=item * B<completion> => I<any> |
1799
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1801
|
|
|
|
|
|
|
|
1802
|
|
|
|
|
|
|
=item * B<config_dirs> => I<array[str]> |
1803
|
|
|
|
|
|
|
|
1804
|
|
|
|
|
|
|
Where to search for configuration files. |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
=item * B<config_filename> => I<str|hash|array[str|hash]> |
1807
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
Configuration file name(s). |
1809
|
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
=item * B<default_format> => I<any> |
1811
|
|
|
|
|
|
|
|
1812
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1813
|
|
|
|
|
|
|
|
1814
|
|
|
|
|
|
|
=item * B<default_subcommand> => I<str> |
1815
|
|
|
|
|
|
|
|
1816
|
|
|
|
|
|
|
=item * B<description> => I<any> |
1817
|
|
|
|
|
|
|
|
1818
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1819
|
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
|
=item * B<env_name> => I<str> |
1821
|
|
|
|
|
|
|
|
1822
|
|
|
|
|
|
|
Name of environment variable name that sets default options. |
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
=item * B<exit> => I<any> |
1825
|
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1827
|
|
|
|
|
|
|
|
1828
|
|
|
|
|
|
|
=item * B<extra_urls_for_version> => I<array[riap::url]> |
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
More URLs to show version for --version. |
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
Currently not implemented in Perinci::CmdLine::Inline. |
1833
|
|
|
|
|
|
|
|
1834
|
|
|
|
|
|
|
=item * B<formats> => I<any> |
1835
|
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1837
|
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
=item * B<get_subcommand_from_arg> => I<any> |
1839
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
=item * B<include> => I<array[perl::modname]> |
1843
|
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
|
Include extra modules. |
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
=item * B<log> => I<bool> (default: 0) |
1847
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
Whether to enable logging. |
1849
|
|
|
|
|
|
|
|
1850
|
|
|
|
|
|
|
=item * B<meta> => I<hash> |
1851
|
|
|
|
|
|
|
|
1852
|
|
|
|
|
|
|
An alternative to specifying `url`. |
1853
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
=item * B<meta_is_normalized> => I<bool> |
1855
|
|
|
|
|
|
|
|
1856
|
|
|
|
|
|
|
=item * B<output_file> => I<filename> |
1857
|
|
|
|
|
|
|
|
1858
|
|
|
|
|
|
|
Set output file, defaults to stdout. |
1859
|
|
|
|
|
|
|
|
1860
|
|
|
|
|
|
|
=item * B<overwrite> => I<bool> |
1861
|
|
|
|
|
|
|
|
1862
|
|
|
|
|
|
|
=item * B<pack_deps> => I<bool> (default: 1) |
1863
|
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
Whether to pack dependencies into the script. |
1865
|
|
|
|
|
|
|
|
1866
|
|
|
|
|
|
|
By default, Perinci::CmdLine::Inline will use datapacking technique (i.e. embed |
1867
|
|
|
|
|
|
|
dependencies into DATA section and load it on-demand using require() hook) to |
1868
|
|
|
|
|
|
|
make the script freestanding. However, in some situation this is unwanted, e.g. |
1869
|
|
|
|
|
|
|
when we want to produce a script that can be packaged as a Debian package |
1870
|
|
|
|
|
|
|
(Debian policy forbids embedding convenience copy of code, |
1871
|
|
|
|
|
|
|
https://www.debian.org/doc/debian-policy/ch-source.html#s-embeddedfiles ). |
1872
|
|
|
|
|
|
|
|
1873
|
|
|
|
|
|
|
=item * B<pass_cmdline_object> => I<bool> (default: 0) |
1874
|
|
|
|
|
|
|
|
1875
|
|
|
|
|
|
|
Whether to pass Perinci::CmdLine::Inline object. |
1876
|
|
|
|
|
|
|
|
1877
|
|
|
|
|
|
|
=item * B<pod> => I<bool> (default: 1) |
1878
|
|
|
|
|
|
|
|
1879
|
|
|
|
|
|
|
Whether to generate POD for the script. |
1880
|
|
|
|
|
|
|
|
1881
|
|
|
|
|
|
|
=item * B<read_config> => I<bool> (default: 1) |
1882
|
|
|
|
|
|
|
|
1883
|
|
|
|
|
|
|
Whether the CLI script should read configuration files. |
1884
|
|
|
|
|
|
|
|
1885
|
|
|
|
|
|
|
=item * B<read_env> => I<bool> |
1886
|
|
|
|
|
|
|
|
1887
|
|
|
|
|
|
|
Whether CLI script should read environment variable that sets default options. |
1888
|
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
|
=item * B<riap_client> => I<any> |
1890
|
|
|
|
|
|
|
|
1891
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1892
|
|
|
|
|
|
|
|
1893
|
|
|
|
|
|
|
=item * B<riap_client_args> => I<any> |
1894
|
|
|
|
|
|
|
|
1895
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1896
|
|
|
|
|
|
|
|
1897
|
|
|
|
|
|
|
=item * B<riap_version> => I<any> |
1898
|
|
|
|
|
|
|
|
1899
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1900
|
|
|
|
|
|
|
|
1901
|
|
|
|
|
|
|
=item * B<script_name> => I<str> |
1902
|
|
|
|
|
|
|
|
1903
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1904
|
|
|
|
|
|
|
|
1905
|
|
|
|
|
|
|
=item * B<script_summary> => I<str> |
1906
|
|
|
|
|
|
|
|
1907
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1908
|
|
|
|
|
|
|
|
1909
|
|
|
|
|
|
|
=item * B<script_version> => I<str> |
1910
|
|
|
|
|
|
|
|
1911
|
|
|
|
|
|
|
Script version (otherwise will use version from url metadata). |
1912
|
|
|
|
|
|
|
|
1913
|
|
|
|
|
|
|
=item * B<script_version_from_main_version> => I<bool> |
1914
|
|
|
|
|
|
|
|
1915
|
|
|
|
|
|
|
Use script's $main::VERSION for the version. |
1916
|
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
=item * B<shebang> => I<str> |
1918
|
|
|
|
|
|
|
|
1919
|
|
|
|
|
|
|
Set shebang line. |
1920
|
|
|
|
|
|
|
|
1921
|
|
|
|
|
|
|
=item * B<skip_format> => I<bool> (default: 0) |
1922
|
|
|
|
|
|
|
|
1923
|
|
|
|
|
|
|
Assume that function returns raw text that need no formatting, do not offer --format, --json, --naked-res. |
1924
|
|
|
|
|
|
|
|
1925
|
|
|
|
|
|
|
=item * B<stripper> => I<bool> (default: 0) |
1926
|
|
|
|
|
|
|
|
1927
|
|
|
|
|
|
|
Whether to strip code using Perl::Stripper. |
1928
|
|
|
|
|
|
|
|
1929
|
|
|
|
|
|
|
=item * B<sub_name> => I<str> |
1930
|
|
|
|
|
|
|
|
1931
|
|
|
|
|
|
|
=item * B<subcommands> => I<hash> |
1932
|
|
|
|
|
|
|
|
1933
|
|
|
|
|
|
|
=item * B<tags> => I<any> |
1934
|
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
|
Currently does nothing, provided only for compatibility with Perinci::CmdLine::Base. |
1936
|
|
|
|
|
|
|
|
1937
|
|
|
|
|
|
|
=item * B<url> => I<riap::url> |
1938
|
|
|
|
|
|
|
|
1939
|
|
|
|
|
|
|
Program URL. |
1940
|
|
|
|
|
|
|
|
1941
|
|
|
|
|
|
|
=item * B<use_cleanser> => I<bool> (default: 1) |
1942
|
|
|
|
|
|
|
|
1943
|
|
|
|
|
|
|
Whether to use data cleanser routine first before producing JSON. |
1944
|
|
|
|
|
|
|
|
1945
|
|
|
|
|
|
|
When a function returns result, and the user wants to display the result as |
1946
|
|
|
|
|
|
|
JSON, the result might need to be cleansed first (e.g. using L<Data::Clean>) |
1947
|
|
|
|
|
|
|
before it can be encoded to JSON, for example it might contain Perl objects or |
1948
|
|
|
|
|
|
|
scalar references or other stuffs. If you are sure that your function does not |
1949
|
|
|
|
|
|
|
produce those kinds of data, you can set this to false to produce a more |
1950
|
|
|
|
|
|
|
lightweight script. |
1951
|
|
|
|
|
|
|
|
1952
|
|
|
|
|
|
|
=item * B<use_utf8> => I<bool> (default: 0) |
1953
|
|
|
|
|
|
|
|
1954
|
|
|
|
|
|
|
Whether to set utf8 flag on output. |
1955
|
|
|
|
|
|
|
|
1956
|
|
|
|
|
|
|
=item * B<validate_args> => I<bool> (default: 1) |
1957
|
|
|
|
|
|
|
|
1958
|
|
|
|
|
|
|
Whether the CLI script should validate arguments using schemas. |
1959
|
|
|
|
|
|
|
|
1960
|
|
|
|
|
|
|
=item * B<with_debug> => I<bool> |
1961
|
|
|
|
|
|
|
|
1962
|
|
|
|
|
|
|
Generate script with debugging outputs. |
1963
|
|
|
|
|
|
|
|
1964
|
|
|
|
|
|
|
|
1965
|
|
|
|
|
|
|
=back |
1966
|
|
|
|
|
|
|
|
1967
|
|
|
|
|
|
|
Returns an enveloped result (an array). |
1968
|
|
|
|
|
|
|
|
1969
|
|
|
|
|
|
|
First element ($status_code) is an integer containing HTTP-like status code |
1970
|
|
|
|
|
|
|
(200 means OK, 4xx caller error, 5xx function error). Second element |
1971
|
|
|
|
|
|
|
($reason) is a string containing error message, or something like "OK" if status is |
1972
|
|
|
|
|
|
|
200. Third element ($payload) is the actual result, but usually not present when enveloped result is an error response ($status_code is not 2xx). Fourth |
1973
|
|
|
|
|
|
|
element (%result_meta) is called result metadata and is optional, a hash |
1974
|
|
|
|
|
|
|
that contains extra information, much like how HTTP response headers provide additional metadata. |
1975
|
|
|
|
|
|
|
|
1976
|
|
|
|
|
|
|
Return value: (any) |
1977
|
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
|
=head1 FAQ |
1979
|
|
|
|
|
|
|
|
1980
|
|
|
|
|
|
|
=head2 What about tab completion? |
1981
|
|
|
|
|
|
|
|
1982
|
|
|
|
|
|
|
Use L<App::GenPericmdCompleterScript> to generate a separate completion script. |
1983
|
|
|
|
|
|
|
If you use L<Dist::Zilla>, see also L<Dist::Zilla::Plugin::GenPericmdScript> |
1984
|
|
|
|
|
|
|
which lets you generate script (and its completion script) during build. |
1985
|
|
|
|
|
|
|
|
1986
|
|
|
|
|
|
|
=head1 HOMEPAGE |
1987
|
|
|
|
|
|
|
|
1988
|
|
|
|
|
|
|
Please visit the project's homepage at L<https://metacpan.org/release/Perinci-CmdLine-Inline>. |
1989
|
|
|
|
|
|
|
|
1990
|
|
|
|
|
|
|
=head1 SOURCE |
1991
|
|
|
|
|
|
|
|
1992
|
|
|
|
|
|
|
Source repository is at L<https://github.com/perlancar/perl-Perinci-CmdLine-Inline>. |
1993
|
|
|
|
|
|
|
|
1994
|
|
|
|
|
|
|
=head1 SEE ALSO |
1995
|
|
|
|
|
|
|
|
1996
|
|
|
|
|
|
|
L<Perinci::CmdLine>, L<Perinci::CmdLine::Any>, L<Perinci::CmdLine::Lite>, |
1997
|
|
|
|
|
|
|
L<Perinci::CmdLine::Classic> |
1998
|
|
|
|
|
|
|
|
1999
|
|
|
|
|
|
|
L<App::GenPericmdScript> |
2000
|
|
|
|
|
|
|
|
2001
|
|
|
|
|
|
|
=head1 AUTHOR |
2002
|
|
|
|
|
|
|
|
2003
|
|
|
|
|
|
|
perlancar <perlancar@cpan.org> |
2004
|
|
|
|
|
|
|
|
2005
|
|
|
|
|
|
|
=head1 CONTRIBUTING |
2006
|
|
|
|
|
|
|
|
2007
|
|
|
|
|
|
|
|
2008
|
|
|
|
|
|
|
To contribute, you can send patches by email/via RT, or send pull requests on |
2009
|
|
|
|
|
|
|
GitHub. |
2010
|
|
|
|
|
|
|
|
2011
|
|
|
|
|
|
|
Most of the time, you don't need to build the distribution yourself. You can |
2012
|
|
|
|
|
|
|
simply modify the code, then test via: |
2013
|
|
|
|
|
|
|
|
2014
|
|
|
|
|
|
|
% prove -l |
2015
|
|
|
|
|
|
|
|
2016
|
|
|
|
|
|
|
If you want to build the distribution (e.g. to try to install it locally on your |
2017
|
|
|
|
|
|
|
system), you can install L<Dist::Zilla>, |
2018
|
|
|
|
|
|
|
L<Dist::Zilla::PluginBundle::Author::PERLANCAR>, and sometimes one or two other |
2019
|
|
|
|
|
|
|
Dist::Zilla plugin and/or Pod::Weaver::Plugin. Any additional steps required |
2020
|
|
|
|
|
|
|
beyond that are considered a bug and can be reported to me. |
2021
|
|
|
|
|
|
|
|
2022
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
2023
|
|
|
|
|
|
|
|
2024
|
|
|
|
|
|
|
This software is copyright (c) 2022, 2021, 2020, 2018, 2017, 2016, 2015 by perlancar <perlancar@cpan.org>. |
2025
|
|
|
|
|
|
|
|
2026
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
2027
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
2028
|
|
|
|
|
|
|
|
2029
|
|
|
|
|
|
|
=head1 BUGS |
2030
|
|
|
|
|
|
|
|
2031
|
|
|
|
|
|
|
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-CmdLine-Inline> |
2032
|
|
|
|
|
|
|
|
2033
|
|
|
|
|
|
|
When submitting a bug or request, please include a test-file or a |
2034
|
|
|
|
|
|
|
patch to an existing test-file that illustrates the bug or desired |
2035
|
|
|
|
|
|
|
feature. |
2036
|
|
|
|
|
|
|
|
2037
|
|
|
|
|
|
|
=cut |