Perinci-CmdLine-Inline
view release on metacpan or search on metacpan
lib/Perinci/CmdLine/Inline.pm view on Meta::CPAN
$req_gen_iter++;
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter(\*STDIN, "'.$type.'", "'.$arg.'")';
} elsif ($type eq 'array') {
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [<STDIN>] }';
} else {
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<STDIN> }';
}
push @l2, " }\n";
} elsif ($cs eq 'stdin_or_files') {
return [400, "arg $arg: More than one cmdline_src=/stdin/ is found (arg=$stdin_seen)"]
if defined $stdin_seen;
$stdin_seen = $arg;
push @l2, ' unless (exists $args->{"'.$arg.'"}) {';
push @l2, ' @check_argv = ();';
if ($arg_spec->{stream}) {
$req_gen_iter++;
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter(\*ARGV, "'.$type.'", "'.$arg.'")';
} elsif ($type eq 'array') {
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [<>] }';
} else {
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<> }';
}
push @l2, " }\n";
} elsif ($cs eq 'stdin_or_args') {
return [400, "arg $arg: More than one cmdline_src=/stdin/ is found (arg=$stdin_seen)"]
if defined $stdin_seen;
$stdin_seen = $arg;
push @l2, ' unless (exists $args->{"'.$arg.'"}) {';
push @l2, ' @check_argv = ();';
if ($arg_spec->{stream}) {
$req_gen_iter++;
push @l2, ' $args->{"'.$arg.'"} = _pci_gen_iter(\*STDIN, "'.$type.'", "'.$arg.'")';
} elsif ($type eq 'array') {
push @l2, ' $args->{"'.$arg.'"} = do { local $/; [map {chomp;$_} <>] }';
} else {
push @l2, ' $args->{"'.$arg.'"} = do { local $/; ~~<> }';
}
push @l2, " }\n";
} else {
return [400, "arg $arg: unknown cmdline_src value '$cs'"];
}
}
unless ($req_gen_iter) {
delete $cd->{sub_srcs}{_pci_gen_iter};
delete $cd->{module_srcs}{'Data::Sah::Util::Type'};
}
} # fill from cmdline_src
push @l2, "\n";
push @l2, ' # fill defaults from "default" property and check against schema', "\n";
GEN_VALIDATION:
{
my $has_validation;
my @l3;
my @modules_for_all_args;
my @req_stmts;
for my $arg (sort keys %$args_prop) {
my $arg_spec = $args_prop->{$arg};
# we don't validate streaming input for now
next if $arg_spec->{stream};
my $arg_schema = $arg_spec->{schema};
my $arg_term = '$args->{"'.$arg.'"}';
if (defined $arg_spec->{default}) {
push @l3, " $arg_term //= ".dmp($arg_spec->{default}).";\n";
}
if ($arg_schema && $cd->{gen_args}{validate_args}) {
$has_validation++;
my $dsah_cd = _dsah_plc->compile(
schema => $arg_schema,
schema_is_normalized => 1,
indent_level => 3,
data_term => $arg_term,
err_term => '$_sahv_err',
return_type => 'str',
core_or_pp => 1,
( whitelist_modules => $cd->{gen_args}{allow_prereq} ) x !!$cd->{gen_args}{allow_prereq},
);
die "Incompatible Data::Sah version (cd v=$dsah_cd->{v}, expected 2)" unless $dsah_cd->{v} == 2;
# add require statements for modules needed during
# validation
for my $mod_rec (@{$dsah_cd->{modules}}) {
next unless $mod_rec->{phase} eq 'runtime';
next if grep { ($mod_rec->{use_statement} && $_->{use_statement} && $_->{use_statement} eq $mod_rec->{use_statement}) ||
$_->{name} eq $mod_rec->{name} } @modules_for_all_args;
push @modules_for_all_args, $mod_rec;
if ($mod_rec->{name} =~ /\A(Scalar::Util::Numeric::PP)\z/) {
_pack_module($cd, $mod_rec->{name});
}
my $mod_is_core = Module::CoreList::More->is_still_core($mod_rec->{name});
log_warn("Validation code requires non-core module '%s'", $mod_rec->{name})
unless $mod_is_core && !$cd->{module_srcs}{$mod_rec->{name}} &&
!($cd->{gen_args}{allow_prereq} && grep { $_ eq $mod_rec->{name} } @{$cd->{gen_args}{allow_prereq}});
# skip modules that we already require at the
# beginning of script
next if exists $cd->{req_modules}{$mod_rec->{name}};
push @req_stmts, _dsah_plc->stmt_require_module($mod_rec);
}
push @l3, " if (exists $arg_term) {\n";
push @l3, " \$_sahv_dpath = [];\n";
push @l3, $dsah_cd->{result}, "\n";
push @l3, " ; if (\$_sahv_err) { return [400, \"Argument validation failed: \$_sahv_err\"] }\n";
push @l3, " } # if date arg exists\n";
}
}
push @l3, "\n";
if ($has_validation) {
push @l2, map {" $_\n"} @req_stmts;
push @l2, " my \$_sahv_dpath;\n";
push @l2, " my \$_sahv_err;\n";
}
push @l2, @l3;
} # GEN_VALIDATION
lib/Perinci/CmdLine/Inline.pm view on Meta::CPAN
getopt => "trace",
summary => "Set logging level to trace",
};
$copts{debug} = {
getopt => "debug",
summary => "Set logging level to debug",
};
$copts{verbose} = {
getopt => "verbose",
summary => "Set logging level to info",
};
$copts{quiet} = {
getopt => "quiet",
summary => "Set logging level to error",
};
$cd->{vars}{'$_pci_log_outputs'} = {};
}
unless ($args{skip_format}) {
$copts{json} = $Perinci::CmdLine::Base::copts{json};
$copts{format} = $Perinci::CmdLine::Base::copts{format};
# "naked_res!" currently not supported by
# Getopt::Long::EvenLess, so we split it. the downside is that
# we don't hide the default, by default.
$copts{naked_res} = {
getopt => "naked-res",
summary => "When outputing as JSON, strip result envelope",
};
$copts{no_naked_res} = {
getopt => "no-naked-res|nonaked-res",
summary => "When outputing as JSON, don't strip result envelope",
};
}
if ($args{subcommands}) {
$copts{subcommands} = $Perinci::CmdLine::Base::copts{subcommands};
$copts{cmd} = $Perinci::CmdLine::Base::copts{cmd};
}
if ($args{read_config}) {
for (qw/config_path no_config config_profile/) {
$copts{$_} = $Perinci::CmdLine::Base::copts{$_};
}
}
if ($args{read_env}) {
for (qw/no_env/) {
$copts{$_} = $Perinci::CmdLine::Base::copts{$_};
}
}
for (qw/page_result/) {
$copts{$_} = $Perinci::CmdLine::Base::copts{$_};
}
$cd->{copts} = \%copts;
}
my $shebang_line;
{
$shebang_line = $args{shebang} // $^X;
$shebang_line = "#!$shebang_line" unless $shebang_line =~ /\A#!/;
$shebang_line .= "\n" unless $shebang_line =~ /\R\z/;
}
# this will be removed if we don't use streaming input or read from
# stdin
$cd->{sub_srcs}{_pci_gen_iter} = <<'_';
require Data::Sah::Util::Type;
my ($fh, $type, $argname) = @_;
if (Data::Sah::Util::Type::is_simple($type)) {
return sub {
# XXX this will be configurable later. currently by default reading
# binary is per-64k while reading string is line-by-line.
local $/ = \(64*1024) if $type eq 'buf';
state $eof;
return undef if $eof;
my $l = <$fh>;
unless (defined $l) {
$eof++; return undef;
}
$l;
};
} else {
my $i = -1;
return sub {
state $eof;
return undef if $eof;
$i++;
my $l = <$fh>;
unless (defined $l) {
$eof++; return undef;
}
eval { $l = _pci_json()->decode($l) };
if ($@) {
die "Invalid JSON in stream argument '$argname' record #$i: $@";
}
$l;
};
}
_
$cd->{sub_srcs}{_pci_err} = <<'_';
my $res = shift;
print STDERR "ERROR $res->[0]: $res->[1]\n";
exit $res->[0]-300;
_
if ($args{with_debug}) {
_pack_module($cd, "Data::Dmp");
_pack_module($cd, "Regexp::Stringify"); # needed by Data::Dmp
$cd->{sub_srcs}{_pci_debug} = <<'_';
require Data::Dmp;
print "DEBUG: ", Data::Dmp::dmp(@_), "\n";
_
}
$cd->{sub_srcs}{_pci_json} = <<'_';
state $json = do {
if (eval { require JSON::XS; 1 }) { JSON::XS->new->canonical(1)->allow_nonref }
else { require JSON::PP; JSON::PP->new->canonical(1)->allow_nonref }
};
$json;
_
$cd->{sub_src_core_deps}{_pci_json}{'JSON::PP'} = 0;
( run in 1.245 second using v1.01-cache-2.11-cpan-140bd7fdf52 )