1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
package App::Ping903::Command;
use strict;
use warnings;
use Getopt::Long;
use Pod::Man;
use Pod::Usage;
use Pod::Find qw(pod_where);
use Carp;
use parent 'Exporter';
use constant {
EX_OK => 0,
EX_FAIL => 1,
EX_USAGE => 2
};
our @EXPORT_OK = qw(EX_OK EX_FAIL EX_USAGE);
our %EXPORT_TAGS = ( 'exit_codes' => [
qw(EX_OK EX_FAIL EX_USAGE)
] );
sub new {
my ($class, $com, $agent, %opts) = @_;
my $self = bless { progname => $com, agent => $agent }, $class;
$self->{options} = {};
$self->{optdef}{'shorthelp|?'} = sub {
pod2usage(-message => $class->pod_usage_msg,
-input => pod_where({-inc => 1}, $class),
-exitstatus => EX_OK)
};
$self->{optdef}{help} = sub {
pod2usage(-exitstatus => EX_OK,
-verbose => 2,
-input => pod_where({-inc => 1}, $class))
};
$self->{optdef}{usage} = sub {
pod2usage(-exitstatus => EX_OK,
-verbose => 0,
-input => pod_where({-inc => 1}, $class))
};
foreach my $k (keys %opts) {
if (ref($opts{$k}) eq 'CODE') {
$self->{optdef}{$k} = sub { &{$opts{$k}}($self, @_ ) }
} elsif (ref($opts{$k})) {
$self->{optdef}{$k} = $opts{$k};
} else {
$self->{optdef}{$k} = \$self->{options}{$opts{$k}}
}
}
$self;
}
sub run {
my $self = shift;
GetOptions(%{$self->{optdef}}) or exit(EX_USAGE);
}
sub agent { shift->{agent} }
sub option {
my $self = shift;
my $name = shift;
if (defined(my $v = shift)) {
croak "too many arguments" if @_;
$self->{options}{$name} = $v;
}
return $self->{options}{$name};
}
sub pod_usage_msg {
my ($class) = @_;
my $msg = "";
open my $fd, '>', \$msg;
my $input = pod_where({-inc => 1}, $class);
pod2usage(-verbose => 99,
-sections => 'NAME',
-output => $fd,
-exitval => 'NOEXIT',
-input => $input);
my @a = split /\n/, $msg;
if ($#a < 1) {
croak "missing or malformed NAME section in " . ($input // $0);
}
$msg = $a[1];
$msg =~ s/^\s+//;
$msg =~ s/ - /: /;
return $msg;
}
sub error {
my ($self, @msg) = @_;
print STDERR "$self->{progname}: ";
print STDERR "@msg\n";
}
sub abend {
my ($self, $code, @msg) = @_;
$self->error(@msg);
exit $code;
}
sub usage_error {
my $self = shift;
$self->abend(EX_USAGE, @_);
}
1;
|
