File Coverage

blib/lib/Getopt/Helpful.pm
Criterion Covered Total %
statement 29 152 19.0
branch 4 54 7.4
condition 1 9 11.1
subroutine 6 18 33.3
pod 11 11 100.0
total 51 244 20.9


line stmt bran cond sub pod time code
1             package Getopt::Helpful;
2              
3 2     2   56184 use strict;
  2         5  
  2         75  
4 2     2   8 use warnings;
  2         5  
  2         51  
5 2     2   75 use Carp;
  2         13  
  2         190  
6              
7 2     2   4078 use Storable qw(dclone);
  2         140888  
  2         7158  
8             our $VERSION = '0.04';
9              
10             =pod
11              
12             =head1 NAME
13              
14             Getopt::Helpful - Integrated option hash / help messages.
15              
16             =head1 STATE
17              
18             This module is still under development, but is being publish on CPAN to
19             satisfy some code which depends on it. The interface may change in a
20             future version and some of the functionality is not yet complete.
21              
22             =head1 SYNOPSIS
23              
24             This module provides methods which integrate help messages into a
25             Getopt::Long option spec. This gathers documentation and declaration
26             into one place and allows you to utilize perl code to state the default
27             values of options in your online help messages (helping you utilize the
28             single-point-of-truth principle.)
29              
30             Additionally, it provides DWIM methods (Get) which allow you to cut some
31             standard error-checking code from your scripts. There is even a handy
32             usage() method which eliminates that silly block of code from the
33             beginning.
34              
35             #!/usr/bin/perl
36              
37             use warnings;
38             use strict;
39              
40             use Getopt::Helpful;
41             my $var1 = "default";
42             my $req_arg;
43              
44             # declare this as 'our' or $main::verbose
45             our $verbose = 0;
46              
47             # every option must be passed into the constructor...
48             my $hopt = Getopt::Helpful->new(
49             usage => 'CALLER [options]',
50             [
51             'var=s', \$default,
52             '',
53             "setting for \$var1 (default: '$var1')"
54             ],
55             [
56             'a|arg', \$req_arg,
57             '',
58             'required argument'
59             ],
60             '+verbose',
61             '+help',
62             );
63              
64             # call GetOptions() behind the scenes (with error-checking)
65             $hopt->Get();
66             $req_arg or ($req_arg = shift);
67              
68             # usage() called with a message results in non-zero exit code
69             $req_arg or $hopt->usage('missing required argument');
70             $verbose and warn "doing stuff now\n";
71             # now do stuff...
72              
73             =head1 AUTHOR
74              
75             Eric L. Wilhelm
76              
77             http://scratchcomputing.com
78              
79             =head1 COPYRIGHT
80              
81             This module is copyright (C) 2004-2006 by Eric L. Wilhelm.
82              
83             =head1 LICENSE
84              
85             This module is distributed under the same terms as Perl. See the Perl
86             source package for details.
87              
88             You may use this software under one of the following licenses:
89              
90             (1) GNU General Public License
91             (found at http://www.gnu.org/copyleft/gpl.html)
92             (2) Artistic License
93             (found at http://www.perl.com/pub/language/misc/Artistic.html)
94              
95             =head1 Modifications
96              
97             The source code of this module is made freely available and
98             distributable under the GPL or Artistic License. Modifications to and
99             use of this software must adhere to one of these licenses. Changes to
100             the code should be noted as such and this notification (as well as the
101             above copyright information) must remain intact on all copies of the
102             code.
103              
104             Additionally, while the author is actively developing this code,
105             notification of any intended changes or extensions would be most helpful
106             in avoiding repeated work for all parties involved. Please contact the
107             author with any such development plans.
108              
109             =head1 SEE ALSO
110              
111             Getopt::Long
112              
113             =cut
114              
115             ########################################################################
116              
117             =head1 Constructor
118              
119             The helper object's values should be completely filled upon creation.
120             The new() function accepts the following three types of arguments:
121              
122             =head2 new
123              
124             The constructor is (currently) the only interface to add contents to the
125             $helper object.
126              
127             =head3 Array references
128              
129             This is the most generic form of option specification. The first two
130             columns should be exactly the same as the hash that you would usually
131             use to feed Getopt::Long. The second two columns are for printing
132             helpful information.
133              
134             # spec , ref , example , message
135             [ 'a|argname=s', \$arg, '', 'a value for argument'],
136              
137             =head3 Key => Value arguments
138              
139             The key => value arguments let you specify values which control specific
140             features.
141              
142             =over
143              
144             =item usage
145              
146             The 'usage' key will be used to create a customized usage message for
147             the usage() function. The value may contain the string 'CALLER' which
148             will be replaced with the value of $0. This is very helpful when you
149             have a program that behaves differently under different names (such as
150             when called through a symlink.) If you specify a usage message, you
151             still need to request the '+help' builtin or include another option
152             which will trigger the $helper->usage() call.
153              
154             usage => 'CALLER inputfile outputfile [options]'
155              
156             =back
157              
158             =head3 Builtins
159              
160             The following builtin options are available by using a '+'
161             string instead of an array reference in the constructor:
162              
163             '+help' -> 'h|help' - calls main::usage() (also see usage())
164             '+verbose' -> 'v|verbose' - increments $main::verbose
165             '+debug' -> 'd|debug' - increments $main::debug
166              
167             If you are using strict, you will want to declare these variables as
168             'our $verbose' and 'our $debug' (or initialize them as $main::verbose,
169             etc.)
170              
171             =head3 Example
172              
173             our $debug = 0;
174             my $helper = Getopt::Helpful->new(
175             usage => 'CALLER [options]',
176             ['choice=s', \$choice, '', 'your choice (default $choice)'],
177             '+debug', # let's user toggle $main::debug
178             '+help', # use a builtin
179             );
180              
181             =cut
182             sub new {
183 4     4 1 2048 my $caller = shift;
184 4   33     25 my $class = ref($caller) || $caller;
185 4         17 my $self = {has => {}, opts => {}};
186 4         11 bless($self, $class);
187 4         9 my @rows = @_;
188 4         16 my %builtins = $self->builtins();
189 4         20 for(my $i = 0; $i < @rows; $i++) {
190 6         8 my $row = $rows[$i];
191             ## warn "work at $row ($i)\n";
192             # array refs are used unchecked...
193 6 100       25 unless(ref($row) eq "ARRAY") {
194             ## warn "work at $row\n";
195 2 50       13 if($row =~ s/^\+//) { # request for a builtin
196 2 50       8 $builtins{$row} or
197             croak("$row is not one of ",
198             join(", ", sort(keys(%builtins))), "\n");
199             # tracking of builtins which are used:
200 2         8 $self->{has}{$row}++;
201 2         9 $rows[$i] = $builtins{$row};
202             }
203             else { # allows "usage => $string," syntax
204             # assume it is a config key
205 0         0 my ($key, $val) = splice(@rows, $i, 2);
206             ## warn "val: $val\n";
207             ## warn "remainder: @rows\n";
208             # XXX some kind of error-checking here?
209 0         0 $self->{opts}{$key} = $val;
210 0         0 $i--;
211 0         0 next;
212             }
213             }
214             # FIXME some tracking of user-defined options would be nice
215             }
216 4         29 $self->{table} = [@rows];
217 4         40 return($self);
218             } # end subroutine new definition
219             ########################################################################
220              
221             =head1 DWIM
222              
223             Do What I Mean methods.
224              
225             =head2 Get
226              
227             Calls GetOptions() with the options builtin to $helper (and optionally a
228             list of other helpers or a hash of plain-old options.)
229              
230             If GetOptions() returns false, we die (hinting at how to get help if
231             '+help' was one of the options given to the constructor.)
232              
233             $helper->Get();
234             # multiple helper objects:
235             $helper->Get(@other_helpers);
236              
237             # mixed method (hash ref must come first)
238             $helper->Get(\%opts, @other_helpers);
239              
240             =cut
241             sub Get {
242 0     0 1 0 my $self = shift;
243 0         0 my @others = @_;
244             #package main; # XXX what was the point of that?
245 0         0 require Getopt::Long;
246 0         0 my %opts = $self->opts();
247             # XXX this area needs some test coverage, but is still waiting on
248             # Getopt::Crazy to get done.
249 0         0 foreach my $obj (@others) {
250 0         0 eval {$obj->can('opts');};
  0         0  
251 0 0       0 if(! $@) {
252             # if it can('opts'), just do that
253 0         0 %opts = (%opts, $obj->opts);
254             }
255             else {
256             # it had better be a hash or it is useless here
257 0 0       0 (ref($obj) eq ("HASH")) or croak("non-helpful object");
258 0         0 %opts = (%opts, %$obj);
259             }
260             }
261             # XXX should we save @ARGV? (probably so...)
262             # (it is required if we're going to make help behave properly,
263             # and for config-file processing.)
264 0         0 @ARGV = $self->juggle_list(\@ARGV, \%opts);
265             # XXX why bother with Getopt::Long at this point?
266 0 0       0 unless(Getopt::Long::GetOptions(%opts)) {
267             # does -h work?
268 0 0       0 my $message = ($self->{has}{help} ? " (-h for help)" : "");
269 0         0 die "invalid options$message\n";
270             }
271             } # end subroutine Get definition
272             ########################################################################
273              
274             =head2 Get_from
275              
276             Equivalent to Get(@extra), but treats @args as a localized @ARGV.
277              
278             $hopt->Get_from(\@args, @extra);
279              
280             =cut
281             sub Get_from {
282 0     0 1 0 my $self = shift;
283 0         0 my ($args, @extra) = @_;
284 0         0 local @ARGV = @$args;
285 0         0 $self->Get(@extra);
286 0         0 @$args = @ARGV;
287             } # end subroutine Get_from definition
288             ########################################################################
289              
290             =head2 ordered
291              
292             Not finished yet. The idea is to have one or more arguments that may be
293             just an ordered list on the command line so that your program could be
294             called as:
295              
296             program infile outfile --option "these are options"
297              
298             or
299              
300             program -o outfile -i infile --option "these are options"
301              
302             Still working on what this should look like, whether it should die if
303             these things are unset, where it should set them (in the references?),
304             how to set default values, etc...
305              
306             $helper->ordered('first_option+r7qe', 'second_option');
307              
308             =cut
309             sub ordered {
310 0     0 1 0 my $self = shift;
311 0         0 die "not finished";
312             } # end subroutine ordered definition
313             ########################################################################
314              
315             =head1 Methods
316              
317             =head2 opts
318              
319             Makes a hash of the first two columns of the table. Better to use Get()
320             instead.
321              
322             GetOptions(
323             $helper->opts()
324             ) or die "invalid arguments (-h for help)\n";
325              
326             =cut
327             sub opts {
328 0     0 1 0 my $self = shift;
329 0         0 my @other;
330 0 0       0 if($self->{conf_table}) {
331 0         0 @other = @{$self->{conf_table}};
  0         0  
332             }
333 0         0 my %hash = map({$_->[0] => $_->[1]} @{$self->{table}}, @other);
  0         0  
  0         0  
334             # print "hash has keys: ", join(", ", keys(%hash)), "\n";
335 0         0 return(%hash);
336             } # end subroutine opts definition
337             ########################################################################
338              
339             =head2 help_table
340              
341             Returns a list of array refs of the first, third, and fourth columns of
342             the table (e.g. you don't need the variable refs for this.)
343              
344             my @table = $helper->help_table();
345              
346             =cut
347             sub help_table {
348 0     0 1 0 my $self = shift;
349 0         0 return(map({[$_->[0], $_->[2], $_->[3]]} @{$self->{table}}));
  0         0  
  0         0  
350             } # end subroutine help_table definition
351             ########################################################################
352              
353             =head2 help_string
354              
355             Returns join()ed string of the help table, with columnation and other
356             fancy stuff (though it could stand to be a bit fancier.)
357              
358             $helper->help_string();
359              
360             If any arguments are passed, help will only be printed for the options
361             which match those arguments.
362              
363             $helper->help_string('foo', 'bar');
364              
365             =cut
366             sub help_string {
367 0     0 1 0 my $self = shift;
368             # First, we switch the Getopt::Long string to something that is more
369             # readable (also, duplicate rows for negatable options?)
370             # Then, we must go through the entire table and calculate the lengths of
371             # each column
372 0         0 my %only;
373 0 0       0 if(@_) {
374             # s/// creates expected behavior?
375 0         0 %only = map({$_ =~ s/^-+//; $_ => 1} @_);
  0         0  
  0         0  
376             }
377 0         0 my @stringtable;
378 0         0 foreach my $row ($self->help_table) {
379 0         0 my ($type, @var) = spec_parse($row->[0]);
380             # print "got type ($type) with: ", join(", ", @var), "\n";
381             # NOTE man pages seem to start at column 8 and allow 6 for arg
382             # before breaking to a newline (follow suit?)
383 0         0 my $item = $row->[1];
384 0 0       0 defined($item) or ($item = '');
385 0 0       0 unless(length($item)) {
386 0 0       0 if(defined($type)) {
387 0         0 my $auto = $row->[0];
388             # just strip
389             # XXX refactor this to use the longest of the @var
390 0         0 $auto =~ s/^(.*\|)//;
391 0         0 $auto =~ s/(?:=|:).*$//;
392 0         0 $item = "<$auto>";
393             }
394             }
395 0         0 my $help = $row->[2];
396             ## warn "var consists of ", join(" and ", map({"'$_'"} @var)), "\n";
397 0 0       0 if(%only) {
398 0         0 my $okay = 0;
399 0         0 foreach my $var (@var) {
400 0         0 my $check = $var;
401 0         0 $check =~ s/^-*//;
402 0 0       0 if($only{$check}) {
403 0         0 $okay = 1;
404 0         0 last;
405             }
406             }
407 0 0       0 $okay or next;
408             }
409 0         0 push(@stringtable, [join(", ", @var), $item, $help]);
410             }
411 0         0 my $string = "\n" . " " x 2 . "options:\n";
412 0 0       0 if(%only) {
413             # XXX problems are caused because --help triggers immediate call
414             # XXX to usage! How to fix this? (think we have to return() or
415             # XXX build a sane message about how we're helpless.)
416             # @stringtable or die;
417             }
418 0         0 foreach my $row (@stringtable) {
419 0         0 $string .= " " . join(" ", @{$row}[0,1]) . "\n" .
  0         0  
420             " " x 8 . $row->[2] . "\n\n";
421             }
422              
423 0         0 return($string);
424             } # end subroutine help_string definition
425             ########################################################################
426              
427             =head1 Internal Methods
428              
429             =head2 builtins
430              
431             Returns a hash of builtin options.
432              
433             %builtins = $helper->builtins();
434              
435             =cut
436             sub builtins {
437 4     4 1 8 my $self = shift;
438             # Q: Why is this in a subroutine?
439             # A: To put $self in scope.
440              
441             # XXX add a BEGIN block which looks for optional modules?
442             # (this would be the key to optionalizing dependencies for the
443             # --with-config, etc right?)
444             return(
445             help => [
446             'h|help',
447 0 0   0     sub { (defined(&main::usage) ? main::usage() : $self->usage())},
448 0   0 0     '', 'show this help message'
449             ],
450             verbose => [
451             # XXX nobody is checking whether v is already used!
452             # going to have to implement that in Getopt::Crazy
453             'v|verbose',
454 0           sub {$main::verbose ||= 0;$main::verbose++;},
455 0   0 0     '', 'be verbose'
456             ],
457             debug => [
458             'd|debug',
459 0           sub {$main::debug ||= 0;$main::debug++;},
460 4         61 '', 'enable debugging messages'
461             ],
462             );
463             } # end subroutine builtins definition
464             ########################################################################
465              
466             =head2 usage
467              
468             If main::usage() is not declared, this method will be called instead
469             (when the -h or --help flag is used.)
470              
471             This is (currently) only able to leverage the values of one $helper (the
472             one where '+help' was declared.)
473              
474             # print to stdout and exit with 0 status:
475             $helper->usage();
476              
477             # print $message and minimal usage on stderr and exit with non-zero
478             $helper->usage($message);
479              
480             The usage message can be controlled by the usage => $string option of
481             the new() constructor. If the usage string is empty, a default of
482             "CALLER" is used. The following strings have special meaning in the
483             usage string.
484              
485             =over
486              
487             =item CALLER
488              
489             If the optional usage string contains the (case-sensitive) string
490             "CALLER", this will be replaced by the calling program's ($0) basename
491             (this is useful when you may want to change the name of a program or
492             alias to it with symlinks.)
493              
494             usage => "CALLER "
495              
496             =item Specific Help
497              
498             If there is anything in @main::ARGV which matches one of the options
499             (less the leading dashes (or it would have already been stripped by
500             GetOptions)), only the help for those options will be returned. What
501             this does is allow your users to say something like:
502              
503             program --help option-name
504              
505             And get a compact help message for only that option.
506              
507             =back
508              
509             =cut
510             sub usage {
511 0     0 1   my $self = shift;
512 0           my $code = 0;
513 0   0       my $usage = $self->{opts}{usage} || "CALLER";
514 0 0         if(@_) {
515 0           $code = 1;
516 0           warn("\n ABORT! ", join("\n", @_) , "\n\n");
517             }
518 0           my $caller = $0;
519 0           $caller =~ s#.*/##;
520 0           $usage =~ s/CALLER/$caller/;
521 0           my $string = "usage:\n $usage\n";
522 0           my @args;
523 0 0         if(@main::ARGV) {
524             # 'program --help option-name' support
525 0           $string = '';
526 0           @args = @main::ARGV;
527             }
528 0 0         if($code) {
529 0           warn "$string\n";
530             }
531             else {
532 0           $string .= $self->help_string(@args);
533 0           print "$string\n";
534             }
535 0           exit($code);
536             } # end subroutine usage definition
537             ########################################################################
538              
539             =head2 juggle_list
540              
541             Juggles an argument list to put help at the front (all arguments before
542             -h or --help are removed.)
543              
544             @list = $self->juggle_list(\@list, \%opts);
545              
546             =cut
547             sub juggle_list {
548             # XXX note: this is just a workaround to the way that Getopt::Long works
549 0     0 1   my $self = shift;
550 0           my ($list, $opts) = @_;
551 0 0         unless($opts->{'h|help'}) {
552 0           return(@$list);
553             }
554 0           my @ret = ();
555 0           for(my $i = $#$list; $i >= 0; $i--) {
556 0           my $it = $list->[$i];
557 0           unshift(@ret, $it);
558 0 0         ($it eq "-h") and last;
559 0 0         ($it eq "--help") and last;
560             }
561 0           return(@ret);
562             } # end subroutine juggle_list definition
563             ########################################################################
564              
565             =head1 Functions
566              
567             =head2 spec_parse
568              
569             Parses the specification according to a minimalistic usage of
570             Getopt::Long, returning an array of the variations and a type
571             character (if the =s, =f, or =i items were found.)
572              
573             ($type, @variations) = spec_parse($spec);
574              
575             =cut
576             sub spec_parse {
577 0     0 1   my $spec = shift;
578 0           my @var;
579 0 0         if($spec =~ s/(.*)\|//) {
580 0           my $short = $1;
581 0           $short = '-' . $short;
582 0           push(@var, $short);
583             }
584 0           my $type = undef();
585 0           my $negatable;
586 0 0         if($spec =~ s/(?:=|:)(.*)$//) {
    0          
587 0           $type = $1;
588             }
589             elsif($spec =~ s/!$//) {
590 0           $negatable = 1;
591             }
592 0           push(@var, "--$spec");
593 0 0         if($negatable) {
594 0           push(@var, "--no$spec");
595             }
596 0           return($type, @var);
597             } # end subroutine spec_parse definition
598             ########################################################################
599              
600              
601             1;