File Coverage

blib/lib/Getopt/optparse.pm
Criterion Covered Total %
statement 45 111 40.5
branch 12 50 24.0
condition 1 9 11.1
subroutine 6 7 85.7
pod 3 5 60.0
total 67 182 36.8


line stmt bran cond sub pod time code
1             package Getopt::optparse;
2              
3 1     1   688 use strict;
  1         1  
  1         26  
4 1     1   4 use Scalar::Util 'reftype';
  1         2  
  1         1194  
5              
6             our $VERSION = '1.6.0';
7            
8             $| = 1;
9              
10             ######################################################
11             sub new {
12             ######################################################
13 1     1 1 527 my ($class, $args) = @_;
14 1         2 my $self;
15              
16             my %defaults;
17 1         3 $defaults{int_parser}{'-h, --help'} = {
18             'help' => 'Show this help message and exita'
19             };
20              
21             # Apply defaults.
22 1         3 for my $key (keys %defaults) {
23 1         2 $self->{$key} = $defaults{$key};
24             }
25              
26             # Apply arguments passed by human.
27             # They may clobber our defaults.
28 1         1 for my $key (keys %{$args}) {
  1         3  
29 0         0 $self->{$key} = $args->{$key};
30             }
31              
32 1         1 bless $self, $class;
33              
34 1         4 return $self;
35             }
36              
37             ######################################################
38             sub add_option {
39             ######################################################
40 1     1 1 2 my $self = shift;
41 1         1 my $optname = shift;
42 1         1 my $optvals = shift;
43              
44             # action, default ,dest, help
45             # TODO: test for dest name collision.
46              
47 1 50       4 if (Scalar::Util::reftype($optvals) eq 'HASH') {
48 1 50       4 if (! $optvals->{dest}) {
49 0         0 printf("%s attribute dest is required.\n", $optname);
50 0         0 exit;
51             }
52              
53 1         4 $self->{parser}{$optname} = $optvals;
54             }
55             else {
56 0         0 print "Attributes must be passed as hashref\n";
57 0         0 exit;
58             }
59             }
60              
61             ######################################################
62             sub parse_args {
63             ######################################################
64 1     1 1 2 my $self = shift;
65 1         2 $self->{cmdline} = join " ", @ARGV;
66 1         2 $self->{cmdline} .= ' ';
67              
68 1         1 my %options;
69              
70 1 50 33     6 if (($self->{cmdline} =~ /--help\s+/) || ($self->{cmdline} =~ /-h\s+/)) {
71 0         0 $self->show_help();
72 0         0 return \%options;
73             }
74              
75 1         1 for my $key (keys %{$self->{parser}}) {
  1         3  
76 1 50       2 if ($self->{parser}{$key}{'dest'}) {
77 1         2 my $parser = $self->{parser}{$key};
78             # Handle default value
79 1 50       2 if ($parser->{default}) {
80 1         2 $options{$parser->{dest}} = $parser->{default};
81             }
82              
83             # Handle count
84 1 50       2 if ($parser->{action} eq 'count') {
85 0         0 $options{$parser->{dest}} = 0;
86             }
87              
88             # Handle store_true
89 1 50       2 if ($parser->{action} eq 'store_true') {
90 0 0       0 if ($self->{cmdline} =~ /$key\s+/) {
91 0         0 $options{$parser->{dest}} = 1;
92             } else {
93 0         0 $options{$parser->{dest}} = 0;
94             }
95             }
96             else {
97             # Populate an empty scalar, which will evaluate to false.
98 1 50       3 if (! $parser->{default}) {
99 0         0 $options{$parser->{dest}} = '';
100             }
101              
102             # Populate a default of blank arrayref, which will evaluate to false.
103 1 50       3 if ($parser->{action} eq 'append') {
104 0         0 $options{$parser->{dest}} = [];
105             }
106              
107             # Match for store_true and count actions.
108 1 50       2 if ($parser->{action} eq 'count') {
109 0 0       0 if (my @matches = ($self->{cmdline} =~ /$key\s+/g)) {
110 0         0 for my $match (@matches) {
111 0         0 $options{$parser->{dest}} += 1;
112             }
113             }
114             }
115              
116             # Search command line option
117 1 50       16 if (my @matches = ($self->{cmdline} =~ /$key=(.*?)\s+/g)) {
118 0 0       0 if ($parser->{action} eq 'append') {
119 0         0 for my $match (@matches) {
120 0         0 push @{$options{$parser->{dest}}}, $match;
  0         0  
121             }
122             }
123             else {
124 0 0       0 if ($matches[0] !~ /^-/) {
125 0         0 $options{$parser->{dest}} = $1;
126             }
127             }
128             }
129             }
130             }
131             }
132              
133 1         15 $self->run_callback(\%options);
134              
135 1         4 return \%options;
136             }
137              
138             ######################################################
139             sub run_callback {
140             ######################################################
141 1     1 0 1 my $self = shift;
142 1         9 my $options = shift;
143              
144 1         2 for my $key (keys %{$self->{parser}}) {
  1         2  
145 1 50       4 if ($self->{parser}{$key}{callback}) {
146 0           my $parser = $self->{parser}{$key};
147 0           $parser->{callback}->($parser, $options);
148             }
149             }
150              
151             }
152              
153             ######################################################
154             sub show_help {
155             ######################################################
156 0     0 0   my $self = shift;
157              
158 0           printf("Usage: %s [options]\n\n", $0);
159 0           printf("Options:\n");
160              
161             # Determine length for text formatting.
162 0           my %max_length = (1 => 22);
163 0           for my $val ('int_parser', 'parser') {
164 0           for my $key (keys %{$self->{$val}}) {
  0            
165 0           my $special;
166 0 0         if ($self->{$val}{$key}{action} eq 'count') {
167 0           $special = '++';
168             }
169 0 0         if ($self->{$val}{$key}{action} eq 'append') {
170 0           $special = '[]';
171             }
172 0           my $length = length($key);
173 0 0 0       if ($self->{$val}{$key}{dest} && ($self->{$val}{$key}{action} ne 'store_true')) {
174 0           $length += length('=' . $self->{$val}{$key}{dest} . $special);
175             }
176 0 0         if ($length > $max_length{1}) {
177 0           $max_length{1} = $length;
178             }
179             }
180             }
181              
182 0           my (@singles, @doubles);
183 0           for my $key (keys %{$self->{parser}}) {
  0            
184 0 0         if ($key =~ /^--\w+/) {
    0          
185 0           push @doubles, $key;
186             }
187             elsif ($key =~ /^-\w+/) {
188 0           push @singles, $key;
189             }
190             }
191              
192 0           my @sorted;
193 0           for my $elmt (sort { length $a <=> length $b } @singles) {
  0            
194 0           push @sorted, $elmt;
195             }
196              
197 0           for my $elmt (sort { length $a <=> length $b } @doubles) {
  0            
198 0           push @sorted, $elmt;
199             }
200              
201             # Print help.
202 0           for my $key(keys %{$self->{int_parser}}) {
  0            
203 0           printf("%-$max_length{1}s : %s\n", $key, $self->{int_parser}{$key}{help});
204             }
205              
206 0           for my $key (@sorted) {
207             # Add special character for actions count and append.
208 0           my $special;
209 0 0         if ($self->{parser}{$key}{action} eq 'count') {
210 0           $special = '++';
211             }
212 0 0         if ($self->{parser}{$key}{action} eq 'append') {
213 0           $special = '[]';
214             }
215              
216 0 0 0       if ($self->{parser}{$key}{dest} && ($self->{parser}{$key}{action} ne 'store_true')) {
217             printf(
218             "%-$max_length{1}s : %s\n",
219             $key . '=' . uc($self->{parser}{$key}{dest}) . $special,
220             $self->{parser}{$key}{help}
221 0           );
222             }
223             else {
224 0           printf("%-$max_length{1}s : %s\n", $key, $self->{parser}{$key}{help});
225             }
226             }
227             }
228              
229             1;
230              
231             =head1 NAME
232              
233             Getopt::optparse - optparse style processing of command line options
234              
235             This library supports both single and double dash options. An equal sign must be used.
236              
237             =head1 SYNOPSIS
238              
239             use Getopt::optparse;
240             my $parser = Getopt::optparse->new();
241             $parser->add_option(
242             '--hostname',
243             {
244             dest => 'hostname',
245             help => 'Remote hostname',
246             default => 'localhost.localdomain'
247             }
248             );
249             $parser->add_option(
250             '--global', {
251             dest => 'global',
252             action => 'store_true',
253             help => 'Show global',
254             default => 0
255             }
256             );
257             $parser->add_option(
258             '--username',
259             {
260             dest => 'username',
261             action => 'append',
262             help => 'Usernames to analyze'
263             }
264             );
265             $parser->add_option(
266             '-v',
267             {
268             dest => 'verbose',
269             action => 'count',
270             help => 'Increment verbosity'
271             }
272             );
273              
274             my $options = $parser->parse_args();
275             printf("Hostname is: %s\n", $options->{hostname});
276             printf("Username is: %s\n", $options->{username});
277              
278             if ($options->{global}) {
279             }
280              
281             for my $uname (@{$options->{username}}) {
282             print $uname, "\n";
283             }
284              
285             =head1 DESCRIPTION
286              
287             Library which allows Python optparse style processing of command line options.
288              
289             =head1 CONSTRUCTOR
290              
291             =over 4
292              
293             =item $parser = Getopt::optparse->new( \%options )
294              
295             Construct a new C object and return it.
296             Hash reference argument may be provided though none are required.
297              
298             =back
299              
300             =head1 METHODS
301              
302             The following methods are available:
303              
304             =over 4
305              
306             =item Getopt::optparse->add_option( 'optionname', {option_attributes} )
307              
308             Add option to be parsed from command line. Accepts two arguments. Both are required:
309              
310             $parser->add_option(
311             '--hostname',
312             {
313             dest => 'hostname',
314             help => 'Remote hostname',
315             default => 'localhost.localdomain'
316             }
317             )
318              
319             =over 4
320              
321             =item Option Name (required)
322              
323             Value to be parsed from command line. --hostname in the above example.
324             This library supports both single and double dash option names..
325              
326             =item Option Attributes hash reference (required)
327              
328             These may include:
329              
330             =over 8
331              
332             =item dest (required)
333              
334             Name of key were parsed option will be stored.
335              
336             =item default (optional)
337              
338             Value of dest if no option is parsed on command line.
339              
340             =item help (optional)
341              
342             Text message displayed when -h or --help is found on command line.
343              
344             =item action (optional)
345              
346             The following actions are supported.
347              
348             =over 8
349              
350             =item store_true
351              
352             Using this makes dest true or false (0 or 1) if the option name is found on the command line.
353              
354             =item append
355              
356             Using this appends each occurrance of an option to an ARRAY reference if option name is found on the command line.
357              
358             =item count
359              
360             Using this increments dest by one for every occurrence if option name is found on the command line.
361              
362             =back
363              
364             =item callback (optional)
365              
366             Allows user to pass code reference which is executed after Getopt::optparse->parse_args() is run. The callback has access to to all parsed options from command line. Placed here as not to clobber other actions.
367              
368             # This example uses a callback to validate that user accounts don't already exist.
369             $parser->add_option(
370             '-username',
371             {
372             dest => 'username',
373             action => 'append',
374             help => 'Username for new ILO account',
375             callback => sub {
376             my ($parser, $options) = @_;
377             for my $uname (@{$options->{username}}) {
378             if ($uname) {
379             my $code = system(sprintf("getent passwd %s 2>&1 > /dev/null", $uname));
380             if (! $code) {
381             printf("Error: -username provided already exists: %s\n", $uname);
382             exit 1;
383             }
384             }
385             else {
386             printf("Error: -username provided not defined: %s\n", $uname);
387             exit 2;
388             }
389             }
390             }
391             }
392             );
393              
394             # This example uses a callback to ensure a hostname is resolvable.
395             $parser->add_option(
396             '-hostname',
397             {
398             dest => 'hostname',
399             help => 'Remote hostname',
400             default => 'cpan.perl.org',
401             callback => sub {
402             my ($parser, $options) = @_;
403             my $hostname = $options->{hostname};
404             if ($hostname) {
405             if ($hostname =~ /(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})/) {
406             printf("Error: -hostname should be resolvable fqdn not IP: %s\n", $hostname);
407             exit 3;
408             }
409             if (! gethostbyname($hostname)) {
410             printf("Error: unable to resolve -hostname: %s\n", $hostname);
411             exit 4;
412             }
413             }
414             }
415             }
416             );
417              
418             # This example uses a callback to validate password integrity.
419             $parser->add_option(
420             '-password',
421             {
422             dest => 'password',
423             help => 'Password for account',
424             callback => sub {
425             my ($parser, $options) = @_;
426             my $password = $options->{password};
427             if ($password) {
428             if ($password !~ /^(?=.*[0-9])(?=.*[A-Z])(?=.*[a-z])/s || (length($options->{password}) < 10)) {
429             print "Error: Password should be at least 10 characters, contain numbers and a lower and upper case letters.\n";
430             exit 5;
431             }
432             }
433             }
434             }
435            
436             );
437              
438             =back
439              
440             =back
441              
442             =item Getopt::optparse->parse_args()
443              
444             Parse added options from command line and return their values as a hash reference.
445              
446             my $options = $parser->parse_args();
447              
448             printf("Hostname is: %s\n", $options->{hostname});
449              
450             for my $uname (@{$options->{username}}) {
451             print $uname, "\n";
452             }
453              
454             =back
455              
456             =head1 AUTHOR
457              
458             Matt Hersant
459              
460             =cut