use
5.010;
our
$VERSION
=
'0.013'
;
has
spec
=> (
is
=>
'ro'
);
has
options
=> (
is
=>
'rw'
);
has
parameters
=> (
is
=>
'rw'
,
default
=>
sub
{ +{} } );
has
commands
=> (
is
=>
'rw'
);
has
argv
=> (
is
=>
'rw'
);
has
argv_orig
=> (
is
=>
'rw'
);
has
validation_errors
=> (
is
=>
'rw'
);
has
op
=> (
is
=>
'rw'
);
has
cmd
=> (
is
=>
'rw'
);
has
response
=> (
is
=>
'rw'
,
default
=>
sub
{ App::Spec::Run::Response->new } );
has
subscribers
=> (
is
=>
'rw'
,
default
=>
sub
{ +{} } );
my
%EVENTS
= (
print_output
=> 1,
global_options
=> 1,
);
sub
process {
my
(
$self
) =
@_
;
my
$plugins
=
$self
->spec->plugins || [];
for
my
$plugin
(
@$plugins
) {
$plugin
->init_run(
$self
);
}
my
@callbacks
;
my
$subscriber_events
=
$self
->subscribers;
for
my
$key
(
qw/ global_options print_output /
) {
my
$subscribers
=
$subscriber_events
->{
$key
};
for
my
$sub
(
@$subscribers
) {
my
$plugin
=
$sub
->{plugin};
my
$method
=
$sub
->{method};
my
$callback
=
sub
{
$plugin
->
$method
(
run
=>
$self
,
@_
);
};
push
@callbacks
,
$callback
;
}
$self
->response->add_callbacks(
$key
=> \
@callbacks
);
}
my
$argv
=
$self
->argv;
unless
(
$argv
) {
$argv
= \
@ARGV
;
$self
->argv(
$argv
);
$self
->argv_orig([
@$argv
]);
}
my
$completion_parameter
=
$ENV
{PERL5_APPSPECRUN_COMPLETION_PARAMETER};
my
%option_specs
;
my
%param_specs
;
unless
(
$self
->op) {
$self
->process_input(
option_specs
=> \
%option_specs
,
param_specs
=> \
%param_specs
,
);
}
unless
(
$self
->response->halted) {
my
$opt
= App::Spec::Run::Validator->new({
options
=>
$self
->options,
option_specs
=> \
%option_specs
,
parameters
=>
$self
->parameters,
param_specs
=> \
%param_specs
,
});
my
%errs
;
my
$ok
=
$opt
->process(
$self
, \
%errs
);
unless
(
$ok
) {
$self
->validation_errors(\
%errs
);
if
(not
$completion_parameter
) {
$self
->error_output;
}
}
}
unless
(
$self
->response->halted) {
my
$op
=
$self
->op;
if
(
$completion_parameter
) {
$self
->completion_output(
param_specs
=> \
%param_specs
,
option_specs
=> \
%option_specs
,
completion_parameter
=>
$completion_parameter
,
);
}
else
{
$self
->run_op(
$op
);
}
}
}
sub
run {
my
(
$self
) =
@_
;
$self
->process;
$self
->finish;
}
sub
run_op {
my
(
$self
,
$op
,
$args
) =
@_
;
$self
->cmd->
$op
(
$self
,
$args
);
}
sub
out {
my
(
$self
,
$text
) =
@_
;
$text
.=
"\n"
if
(not
ref
$text
and
$text
!~ m/\n\z/);
$self
->response->add_output(
$text
);
}
sub
err {
my
(
$self
,
$text
) =
@_
;
$text
.=
"\n"
if
(not
ref
$text
and
$text
!~ m/\n\z/);
$self
->response->add_error(
$text
);
}
sub
halt {
my
(
$self
,
$exit
) =
@_
;
$self
->response->halted(1);
$self
->response->
exit
(
$exit
|| 0);
}
sub
finish {
my
(
$self
) =
@_
;
my
$res
=
$self
->response;
$res
->print_output;
$res
->finished(1);
if
(
my
$exit
=
$res
->
exit
) {
exit
$exit
;
}
}
sub
completion_output {
my
(
$self
,
%args
) =
@_
;
my
$completion_parameter
=
$args
{completion_parameter};
my
$param_specs
=
$args
{param_specs};
my
$option_specs
=
$args
{option_specs};
my
$shell
=
$ENV
{PERL5_APPSPECRUN_SHELL} or
return
;
my
$param
=
$param_specs
->{
$completion_parameter
};
$param
||=
$option_specs
->{
$completion_parameter
};
my
$unique
=
$param
->{unique};
my
$completion
=
$param
->completion or
return
;
my
$op
;
if
(
ref
$completion
) {
$op
=
$completion
->{op} or
return
;
}
else
{
my
$possible_values
=
$param
->
values
or
return
;
$op
=
$possible_values
->{op} or
return
;
}
my
$args
= {
runmode
=>
"completion"
,
parameter
=>
$completion_parameter
,
};
my
$result
=
$self
->run_op(
$op
,
$args
);
my
$string
=
''
;
my
%seen
;
if
(
$unique
) {
my
$params
=
$self
->parameters;
my
$value
=
$params
->{
$completion_parameter
};
$value
= [
$value
]
unless
is_arrayref
$value
;
my
$last
=
pop
@$value
;
@seen
{
@$value
} = (1) x
@$value
;
}
for
my
$item
(
@$result
) {
if
(
ref
$item
eq
'HASH'
) {
my
$name
=
$item
->{name};
$unique
and
$seen
{
$name
}++ and
next
;
my
$desc
=
$item
->{description};
$string
.=
"$name\t$desc\n"
;
}
else
{
$unique
and
$seen
{
$item
}++ and
next
;
$string
.=
"$item\n"
;
}
}
$self
->out(
$string
);
return
;
}
sub
error_output {
my
(
$self
) =
@_
;
my
$errs
=
$self
->validation_errors;
my
@error_output
;
for
my
$key
(
sort
keys
%$errs
) {
my
$errors
=
$errs
->{
$key
};
if
(
$key
eq
"parameters"
or
$key
eq
"options"
) {
for
my
$name
(
sort
keys
%$errors
) {
my
$error
=
$errors
->{
$name
};
$key
=~ s/s$//;
push
@error_output
,
"Error: $key '$name': $error"
;
}
}
else
{
my
$err
= Data::Dumper->Dump([
$errs
], [
'errs'
]);
push
@error_output
,
$err
;
}
}
my
$help
=
$self
->spec->usage(
commands
=>
$self
->commands,
highlights
=>
$errs
,
colored
=>
$self
->colorize_code(
'err'
),
);
$self
->err(
$help
);
for
my
$msg
(
@error_output
) {
$msg
=
$self
->colored(
'err'
, [
qw/ error /
],
$msg
);
$self
->err(
"$msg\n"
);
}
$self
->halt(1);
}
sub
colorize_code {
my
(
$self
,
$out
) =
@_
;
$self
->colorize(
$out
)
?
sub
{
my
$colored
=
$self
->colored(
$out
,
$_
[0],
$_
[1]);
unless
(
defined
wantarray
) {
$_
[1] =
$colored
;
}
return
$colored
;
}
:
sub
{
$_
[1] },
}
sub
colorize {
my
(
$self
,
$out
) =
@_
;
$out
||=
'out'
;
if
((
$ENV
{PERL5_APPSPECRUN_COLOR} //
''
) eq
'always'
) {
return
1;
}
if
((
$ENV
{PERL5_APPSPECRUN_COLOR} //
''
) eq
'never'
) {
return
0;
}
if
(
$out
eq
'out'
and -t STDOUT or
$out
eq
'err'
and -t STDERR) {
return
1;
}
return
0;
}
sub
process_parameters {
my
(
$self
,
%args
) =
@_
;
my
$param_list
=
$args
{parameter_list};
my
$parameters
=
$self
->parameters;
my
$param_specs
=
$args
{param_specs};
for
my
$p
(
@$param_list
) {
my
$name
=
$p
->name;
my
$type
=
$p
->type;
my
$multiple
=
$p
->multiple;
my
$required
=
$p
->required;
my
$value
;
if
(
$multiple
) {
$value
= [@{
$self
->argv }];
@{
$self
->argv } = ();
}
else
{
$value
=
shift
@{
$self
->argv };
}
$parameters
->{
$name
} =
$value
;
$param_specs
->{
$name
} =
$p
;
}
}
sub
process_input {
my
(
$self
,
%args
) =
@_
;
my
%options
;
$self
->options(\
%options
);
my
@cmds
;
my
$spec
=
$self
->spec;
my
$option_specs
=
$args
{option_specs};
my
$param_specs
=
$args
{param_specs};
my
$global_options
=
$spec
->options;
my
$global_parameters
=
$spec
->parameters;
my
@getopt
=
$spec
->make_getopt(
$global_options
, \
%options
,
$option_specs
);
GetOptions(
@getopt
);
$self
->event_globaloptions;
my
$op
=
$self
->op;
$self
->process_parameters(
parameter_list
=>
$global_parameters
,
param_specs
=>
$param_specs
,
);
my
$commands
=
$spec
->subcommands;
my
$opclass
=
$self
->spec->class;
my
$cmd_spec
;
my
$subcommand_required
= 1;
while
(
keys
%$commands
) {
my
$cmd
=
shift
@{
$self
->argv };
if
(not
defined
$cmd
) {
if
(not
$op
or
$subcommand_required
) {
$self
->err(
$spec
->usage(
commands
=> \
@cmds
,
colored
=>
$self
->colorize_code(
'err'
),
highlights
=> {
subcommands
=> 1,
},
));
$self
->err(
$self
->colorize_error(
"Missing subcommand(s)"
) );
$self
->halt(1);
}
last
;
}
$cmd_spec
=
$commands
->{
$cmd
} or
do
{
$self
->err(
$spec
->usage(
commands
=> \
@cmds
,
colored
=>
$self
->colorize_code(
'err'
),
highlights
=> {
subcommands
=> 1,
},
));
$self
->err(
$self
->colorize_error(
"Unknown subcommand '$cmd'"
) );
$self
->halt(1);
last
;
};
$subcommand_required
=
$cmd_spec
->{subcommand_required} // 1;
my
$cmd_options
=
$cmd_spec
->options;
my
@getopt
=
$spec
->make_getopt(
$cmd_options
, \
%options
,
$option_specs
);
GetOptions(
@getopt
);
push
@cmds
,
$cmd
;
$commands
=
$cmd_spec
->subcommands || {};
$op
=
'::'
.
$cmd_spec
->op
if
$cmd_spec
->op;
$opclass
=
$cmd_spec
->class
if
$cmd_spec
->class;
$self
->process_parameters(
parameter_list
=>
$cmd_spec
->parameters,
param_specs
=>
$param_specs
,
);
}
unless
(
$self
->response->halted) {
unless
(
$op
) {
if
(
$spec
->has_subcommands) {
$self
->err(
"Missing op for commands (@cmds)\n"
);
my
$help
=
$spec
->usage(
commands
=> \
@cmds
,
colored
=>
$self
->colorize_code(
'err'
),
);
$self
->err(
$help
);
$self
->halt(1);
}
else
{
$op
=
"::execute"
;
}
}
$self
->commands(\
@cmds
);
$self
->options(\
%options
);
if
(
$op
=~ m/^::/) {
$op
=
$opclass
.
$op
;
}
$self
->op(
$op
);
return
$op
;
}
return
;
}
sub
colorize_error {
my
(
$self
,
$msg
) =
@_
;
$msg
=
$self
->colored(
'err'
, [
qw/ error /
],
$msg
) .
"\n"
;
}
sub
colored {
my
(
$self
,
$out
,
$colors
,
$msg
) =
@_
;
$colors
= [
map
{
$_
eq
'error'
?
qw/ bold red /
:
$_
}
@$colors
];
$self
->colorize(
$out
)
and
$msg
= Term::ANSIColor::colored(
$colors
,
$msg
);
return
$msg
;
}
sub
subscribe {
my
(
$self
,
%args
) =
@_
;
for
my
$event
(
sort
keys
%args
) {
next
unless
exists
$EVENTS
{
$event
};
my
$info
=
$args
{
$event
};
push
@{
$self
->subscribers->{
$event
} },
$info
;
}
}
sub
event_globaloptions {
my
(
$self
) =
@_
;
my
$subscribers
=
$self
->subscribers->{global_options};
for
my
$sub
(
@$subscribers
) {
my
$plugin
=
$sub
->{plugin};
my
$method
=
$sub
->{method};
$plugin
->
$method
(
run
=>
$self
);
}
}
1;