=>
$INC
{
'App/FatPacker/Trace.pm'
} ? 0
:
eval
'use Sub::Name; 1'
? 1
: 0;
our
$VERSION
=
eval
'0.01'
;
our
$PERLDOC
=
'perldoc'
;
my
$ANON
= 1;
sub
__new_sub {
my
(
$fqn
,
$code
) =
@_
;
no
strict
'refs'
;
*$fqn
= Sub::Name::subname(
$fqn
,
$code
)
if
SUB_NAME_IS_AVAILABLE;
*$fqn
=
$code
unless
SUB_NAME_IS_AVAILABLE;
}
sub
option {
my
$self
=
shift
;
my
$type
=
shift
or
die
'Usage: option $type => ...'
;
my
$name
=
shift
or
die
'Usage: option $type => $name => ...'
;
my
$documentation
=
shift
or
die
'Usage: option $type => $name => $documentation, ...'
;
my
(
$default
,
@args
);
if
(
@_
% 2) {
$default
=
shift
;
@args
=
@_
;
}
else
{
@args
=
@_
;
}
push
@{
$self
->{
'options'
} }, {
default
=>
$default
,
@args
,
type
=>
$type
,
name
=>
$name
,
documentation
=>
$documentation
,
};
return
$self
;
}
sub
documentation {
return
$_
[0]->{
'documentation'
}
if
(
@_
== 1);
$_
[0]->{
'documentation'
} =
$_
[1] or
die
'Usage: documentation $file|$module_name;'
;
return
$_
[0];
}
sub
version {
return
$_
[0]->{
'version'
}
if
(
@_
== 1);
$_
[0]->{
'version'
} =
$_
[1] or
die
'Usage: version $module_name|$num;'
;
return
$_
[0];
}
sub
extends
{
my
$self
=
shift
;
$self
->{
'extends'
} = [
@_
];
return
$self
;
}
sub
app {
my
(
$self
,
$code
) =
@_
;
my
$app
= {};
my
$parser
=
$self
->_option_parser;
my
(
@options_spec
,
%defaults
,
$application_class
);
for
my
$option
(@{
$self
->{
'options'
} }) {
push
@options_spec
,
$self
->_calculate_option_spec(
$option
);
$defaults
{
$option
->{
'name'
}} =
$option
->{
'default'
}
if
(
exists
$option
->{
'default'
});
}
$parser
->getoptions(
$app
,
@options_spec
,
$self
->_default_options);
if
(
$app
->{
'help'
}) {
$self
->print_help;
$self
->_exit(
'help'
);
}
elsif
(
$app
->{
'man'
}) {
system
$PERLDOC
=>
$self
->documentation;
$self
->_exit($? >> 8);
}
elsif
(
$app
->{
'version'
}) {
$self
->print_version;
$self
->_exit(
'version'
);
}
$application_class
=
$self
->_generate_application_class(
$code
);
$app
=
$application_class
->new({
%defaults
,
map
{
my
$k
=
$self
->_option_to_attr(
$_
);
$k
=>
$app
->{
$_
} }
keys
%$app
,
});
return
$app
if
(
defined
wantarray
);
$self
->_exit(
$app
->run(
@ARGV
));
}
sub
_calculate_option_spec {
my
(
$self
,
$option
) =
@_
;
my
$spec
=
$self
->_attr_to_option(
$option
->{
'name'
});
if
(
$option
->{
'type'
} =~ /^(?:bool|flag)/i) {
$spec
.=
'!'
}
elsif
(
$option
->{
'type'
} =~ /^inc/) {
$spec
.=
'+'
}
elsif
(
$option
->{
'type'
} =~ /^str/) {
$spec
.=
'=s'
}
elsif
(
$option
->{
'type'
} =~ /^
int
/i) {
$spec
.=
'=i'
}
elsif
(
$option
->{
'type'
} =~ /^num/i) {
$spec
.=
'=f'
}
elsif
(
$option
->{
'type'
} =~ /^file/) {
$spec
.=
'=s'
}
elsif
(
$option
->{
'type'
} =~ /^dir/) {
$spec
.=
'=s'
}
else
{
die
'Usage: option {bool|flag|inc|str|int|num|file|dir} ...'
}
return
$spec
;
}
sub
_default_options {
my
$self
=
shift
;
my
@default
;
push
@default
,
'help'
;
push
@default
,
'man'
if
(
$self
->documentation);
push
@default
,
'version'
if
(
$self
->version);
return
@default
;
}
sub
_generate_application_class {
my
(
$self
,
$code
) =
@_
;
my
$application_class
=
$self
->{
'caller'
}[1];
my
$extends
=
$self
->{
'extends'
} || [];
my
@required
;
$application_class
=~ s!\W!_!g;
$application_class
=
join
'::'
,
ref
(
$self
),
"__ANON__${ANON}__"
,
$application_class
;
$ANON
++;
eval
qq[
package $application_class;
use base qw/ @$extends /;
1;
]
or
die
"Failed to generate class: $@"
;
{
no
strict
'refs'
;
my
$methods
= \%{
'app::'
};
__new_sub
"$application_class\::new"
=>
sub
{
my
$class
=
shift
;
bless
shift
,
$class
}
unless
(
grep
{
$_
->can(
'new'
) }
@$extends
);
__new_sub
"$application_class\::_script"
=>
sub
{
$self
};
__new_sub
"$application_class\::run"
=>
sub
{
my
(
$app
,
@extra
) =
@_
;
if
(
@required
=
grep
{ not
defined
$app
->{
$_
} }
@required
) {
my
$required
=
join
', '
,
map
{
'--'
.
$self
->_attr_to_option(
$_
) }
@required
;
$app
->_script->print_help;
die
"Required attribute missing: $required\n"
;
}
return
$app
->
$code
(
@extra
);
};
for
my
$option
(@{
$self
->{
'options'
} }) {
my
$name
=
$option
->{
'name'
};
my
$fqn
=
join
'::'
,
$application_class
,
$option
->{
'name'
};
__new_sub
$fqn
=>
sub
{
$_
[0]->{
$name
} };
push
@required
,
$name
if
(
$option
->{
'required'
});
}
for
my
$name
(
keys
%$methods
) {
my
$code
= *{
$methods
->{
$name
}}{
'CODE'
} or
next
;
my
$fqn
=
join
'::'
,
$application_class
,
$name
;
__new_sub
$fqn
=>
$code
;
delete
$methods
->{
$name
};
}
}
return
$application_class
;
}
sub
options {
$_
[0]->{
'options'
} }
sub
_option_parser {
$_
[0]->{
'_option_parser'
} ||= Getopt::Long::Parser->new(
config
=> [
qw( no_auto_help no_auto_version pass_through )
]) }
sub
new {
my
(
$class
,
$args
) =
@_
;
my
$self
=
bless
$args
,
$class
;
$self
->{
'options'
} ||= [];
$self
->{
'caller'
} or
die
'Usage: $self->new({ caller => [...], ... })'
;
return
$self
;
}
sub
print_help {
my
$self
=
shift
;
my
@options
= @{
$self
->{
'options'
} };
my
$width
= 0;
push
@options
, {
name
=>
''
};
push
@options
, {
name
=>
'help'
,
documentation
=>
'Print this help text'
};
push
@options
, {
name
=>
'man'
,
documentation
=>
'Display manual for this application'
}
if
(
$self
->documentation);
push
@options
, {
name
=>
'version'
,
documentation
=>
'Print application name and version'
}
if
(
$self
->version);
push
@options
, {
name
=>
''
};
OPTION:
for
my
$option
(
@options
) {
my
$length
=
length
$option
->{
'name'
};
$width
=
$length
if
(
$width
<
$length
);
}
print
"Usage:\n"
;
OPTION:
for
my
$option
(
@options
) {
my
$name
=
$self
->_attr_to_option(
$option
->{
'name'
}) or
do
{
print
"\n"
;
next
OPTION };
printf
(
" %s --%-${width}s %s\n"
,
$option
->{
'required'
} ?
'*'
:
' '
,
$name
,
$option
->{
'documentation'
},
);
}
return
$self
;
}
sub
print_version {
my
$self
=
shift
;
my
$version
=
$self
->version or
die
'Cannot print version without version()'
;
unless
(
$version
=~ m!^\d!) {
eval
"use $version; 1"
or
die
"Could not load $version: $@"
;
$version
=
$version
->VERSION;
}
printf
"%s version %s\n"
, File::Basename::basename($0),
$version
;
}
sub
_exit {
my
(
$self
,
$reason
) =
@_
;
exit
0
unless
(
$reason
=~ /^\d+$/);
exit
$reason
;
}
sub
_attr_to_option {
local
$_
=
$_
[1] or
return
;
s!_!-!g;
$_
;
}
sub
_option_to_attr {
local
$_
=
$_
[1] or
return
;
s!-!_!g;
$_
;
}
sub
import
{
my
$class
=
shift
;
my
@caller
= CORE::
caller
(1);
my
$self
=
$class
->new({
caller
=> \
@caller
});
strict->
import
;
warnings->
import
;
no
strict
'refs'
;
no
warnings
'redefine'
;
*{
"$caller[0]\::app"
} =
sub
(&) {
$self
->app(
@_
) };
*{
"$caller[0]\::option"
} =
sub
{
$self
->option(
@_
) };
*{
"$caller[0]\::version"
} =
sub
{
$self
->version(
@_
) };
*{
"$caller[0]\::documentation"
} =
sub
{
$self
->documentation(
@_
) };
*{
"$caller[0]\::method"
} =
sub
{
$self
->method(
@_
) };
*{
"$caller[0]\::extends"
} =
sub
{
$self
->
extends
(
@_
) };
}
1;