File Coverage

blib/lib/Getopt/Long/Descriptive.pm
Criterion Covered Total %
statement 198 211 93.8
branch 62 82 75.6
condition 31 47 65.9
subroutine 30 32 93.7
pod 3 3 100.0
total 324 375 86.4


line stmt bran cond sub pod time code
1 2     2   80510 use strict;
  2         15  
  2         59  
2 2     2   11 use warnings;
  2         4  
  2         81  
3             package Getopt::Long::Descriptive 0.110;
4             # ABSTRACT: Getopt::Long, but simpler and more powerful
5              
6 2     2   42 use v5.10.1;
  2         8  
7              
8 2     2   12 use Carp qw(carp croak);
  2         3  
  2         166  
9 2     2   14 use File::Basename ();
  2         5  
  2         62  
10 2     2   1574 use Getopt::Long 2.33;
  2         26469  
  2         51  
11 2     2   345 use List::Util qw(first);
  2         4  
  2         245  
12 2     2   1098 use Params::Validate 0.97 qw(:all);
  2         17898  
  2         353  
13 2     2   18 use Scalar::Util ();
  2         5  
  2         38  
14              
15 2     2   950 use Getopt::Long::Descriptive::Opts;
  2         6  
  2         61  
16 2     2   876 use Getopt::Long::Descriptive::Usage;
  2         16  
  2         298  
17              
18             #pod =head1 SYNOPSIS
19             #pod
20             #pod use Getopt::Long::Descriptive;
21             #pod
22             #pod my ($opt, $usage) = describe_options(
23             #pod 'my-program %o ',
24             #pod [ 'server|s=s', "the server to connect to", { required => 1 } ],
25             #pod [ 'port|p=i', "the port to connect to", { default => 79 } ],
26             #pod [],
27             #pod [ 'verbose|v', "print extra stuff" ],
28             #pod [ 'help', "print usage message and exit", { shortcircuit => 1 } ],
29             #pod );
30             #pod
31             #pod print($usage->text), exit if $opt->help;
32             #pod
33             #pod Client->connect( $opt->server, $opt->port );
34             #pod
35             #pod print "Connected!\n" if $opt->verbose;
36             #pod
37             #pod ...and running C will produce:
38             #pod
39             #pod my-program [-psv] [long options...]
40             #pod -s --server the server to connect to
41             #pod -p --port the port to connect to
42             #pod
43             #pod -v --verbose print extra stuff
44             #pod --help print usage message and exit
45             #pod
46             #pod =head1 DESCRIPTION
47             #pod
48             #pod Getopt::Long::Descriptive is yet another Getopt library. It's built atop
49             #pod Getopt::Long, and gets a lot of its features, but tries to avoid making you
50             #pod think about its huge array of options.
51             #pod
52             #pod It also provides usage (help) messages, data validation, and a few other useful
53             #pod features.
54             #pod
55             #pod =head1 FUNCTIONS
56             #pod
57             #pod Getopt::Long::Descriptive only exports one routine by default:
58             #pod C. All GLD's exports are exported by L.
59             #pod
60             #pod =head2 describe_options
61             #pod
62             #pod my ($opt, $usage) = describe_options($usage_desc, @opt_spec, \%arg);
63             #pod
64             #pod This routine inspects C<@ARGV> for options that match the supplied spec. If all
65             #pod the options are valid then it returns the options given and an object for
66             #pod generating usage messages; if not then it dies with an explanation of what was
67             #pod wrong and a usage message.
68             #pod
69             #pod The C<$opt> object will be a dynamically-generated subclass of
70             #pod L. In brief, each of the options in
71             #pod C<@opt_spec> becomes an accessor method on the object, using the first-given
72             #pod name, with dashes converted to underscores. For more information, see the
73             #pod documentation for the Opts class.
74             #pod
75             #pod The C<$usage> object will be a L object,
76             #pod which provides a C method to get the text of the usage message and C
77             #pod to die with it. For more methods and options, consults the documentation for
78             #pod the Usage class.
79             #pod
80             #pod =head3 $usage_desc
81             #pod
82             #pod The C<$usage_desc> parameter to C is a C-like string
83             #pod that is used in generating the first line of the usage message. It's a
84             #pod one-line summary of how the command is to be invoked. A typical usage
85             #pod description might be:
86             #pod
87             #pod $usage_desc = "%c %o ";
88             #pod
89             #pod C<%c> will be replaced with what Getopt::Long::Descriptive thinks is the
90             #pod program name (it's computed from C<$0>, see L).
91             #pod
92             #pod C<%o> will be replaced with a list of the short options, as well as the text
93             #pod "[long options...]" if any have been defined.
94             #pod
95             #pod The rest of the usage description can be used to summarize what arguments are
96             #pod expected to follow the program's options, and is entirely free-form.
97             #pod
98             #pod Literal C<%> characters will need to be written as C<%%>, just like with
99             #pod C.
100             #pod
101             #pod =head3 @opt_spec
102             #pod
103             #pod The C<@opt_spec> part of the args to C is used to configure
104             #pod option parsing and to produce the usage message. Each entry in the list is an
105             #pod arrayref describing one option, like this:
106             #pod
107             #pod @opt_spec = (
108             #pod [ "verbose|V" => "be noisy" ],
109             #pod [ "logfile=s" => "file to log to" ],
110             #pod );
111             #pod
112             #pod The first value in the arrayref is a Getopt::Long-style option specification.
113             #pod In brief, they work like this: each one is a pipe-delimited list of names,
114             #pod optionally followed by a type declaration. Type declarations are '=x' or ':x',
115             #pod where C<=> means a value is required and C<:> means it is optional. I may
116             #pod be 's' to indicate a string is required, 'i' for an integer, or 'f' for a
117             #pod number with a fractional part. The type spec may end in C<@> to indicate that
118             #pod the option may appear multiple times.
119             #pod
120             #pod For more information on how these work, see the L documentation.
121             #pod
122             #pod The first name given should be the canonical name, as it will be used as the
123             #pod accessor method on the C<$opt> object. Dashes in the name will be converted to
124             #pod underscores, and all letters will be lowercased. For this reason, all options
125             #pod should generally have a long-form name.
126             #pod
127             #pod The second value in the arrayref is a description of the option, for use in the
128             #pod usage message.
129             #pod
130             #pod =head4 Special Option Specifications
131             #pod
132             #pod If the option specification (arrayref) is empty, it will have no effect other
133             #pod than causing a blank line to appear in the usage message.
134             #pod
135             #pod If the option specification contains only one element, it will be printed in
136             #pod the usage message with no other effect. If the element is a reference, its
137             #pod referent will be printed as-is. Otherwise, it will be reformatted like other
138             #pod text in the usage message.
139             #pod
140             #pod If the option specification contains a third element, it adds extra constraints
141             #pod or modifiers to the interpretation and validation of the value. These are the
142             #pod keys that may be present in that hashref, and how they behave:
143             #pod
144             #pod =over 4
145             #pod
146             #pod =item implies
147             #pod
148             #pod implies => 'bar'
149             #pod implies => [qw(foo bar)]
150             #pod implies => { foo => 1, bar => 2 }
151             #pod
152             #pod If option I has an "implies" entry, then if I is given, other options
153             #pod will be enabled. The value may be a single option to set, an arrayref of
154             #pod options to set, or a hashref of options to set to specific values.
155             #pod
156             #pod =item required
157             #pod
158             #pod required => 1
159             #pod
160             #pod If an option is required, failure to provide the option will result in
161             #pod C printing the usage message and exiting.
162             #pod
163             #pod =item hidden
164             #pod
165             #pod hidden => 1
166             #pod
167             #pod This option will not show up in the usage text.
168             #pod
169             #pod You can achieve the same behavior by using the string "hidden" for the option's
170             #pod description.
171             #pod
172             #pod =item one_of
173             #pod
174             #pod one_of => \@subopt_specs
175             #pod
176             #pod This is useful for a group of options that are related. Each option
177             #pod spec is added to the list for normal parsing and validation.
178             #pod
179             #pod Your option name will end up with a value of the name of the
180             #pod option that was chosen. For example, given the following spec:
181             #pod
182             #pod [ "mode" => hidden => { one_of => [
183             #pod [ "get|g" => "get the value" ],
184             #pod [ "set|s" => "set the value" ],
185             #pod [ "delete" => "delete it" ],
186             #pod ] } ],
187             #pod
188             #pod No usage text for 'mode' will be displayed, but text for get, set, and delete
189             #pod will be displayed.
190             #pod
191             #pod If more than one of get, set, or delete is given, an error will be thrown.
192             #pod
193             #pod So, given the C<@opt_spec> above, and an C<@ARGV> of C<('--get')>, the
194             #pod following would be true:
195             #pod
196             #pod $opt->get == 1;
197             #pod
198             #pod $opt->mode eq 'get';
199             #pod
200             #pod B: C would not be set if C defaulted to 'get' and no arguments
201             #pod were passed in.
202             #pod
203             #pod Even though the option sub-specs for C are meant to be 'first
204             #pod class' specs, some options don't make sense with them, e.g. C.
205             #pod
206             #pod As a further shorthand, you may specify C options using this form:
207             #pod
208             #pod [ mode => \@option_specs, \%constraints ]
209             #pod
210             #pod
211             #pod =item shortcircuit
212             #pod
213             #pod shortcircuit => 1
214             #pod
215             #pod If this option is present no other options will be returned. Other
216             #pod options present will be checked for proper types, but I for
217             #pod constraints. This provides a way of specifying C<--help> style options.
218             #pod
219             #pod =item Params::Validate
220             #pod
221             #pod In addition, any constraint understood by Params::Validate may be used.
222             #pod
223             #pod For example, to accept positive integers:
224             #pod
225             #pod [ 'max-iterations=i', "maximum number of iterations",
226             #pod { callbacks => { positive => sub { shift() > 0 } } } ],
227             #pod
228             #pod (Internally, all constraints are translated into Params::Validate options or
229             #pod callbacks.)
230             #pod
231             #pod =back
232             #pod
233             #pod =head3 %arg
234             #pod
235             #pod The C<%arg> to C is optional. If the last parameter is a
236             #pod hashref, it contains extra arguments to modify the way C
237             #pod works. Valid arguments are:
238             #pod
239             #pod getopt_conf - an arrayref of strings, passed to Getopt::Long::Configure
240             #pod show_defaults - a boolean which controls whether an option's default
241             #pod value (if applicable) is shown as part of the usage message
242             #pod (for backward compatibility this defaults to false)
243             #pod
244             #pod =head2 prog_name
245             #pod
246             #pod This routine, exported on demand, returns the basename of C<$0>, grabbed at
247             #pod compile-time. You can override this guess by calling C
248             #pod yourself.
249             #pod
250             #pod =head1 OTHER EXPORTS
251             #pod
252             #pod =head2 C<-types>
253             #pod
254             #pod Any of the Params::Validate type constants (C, etc.) can be imported as
255             #pod well. You can get all of them at once by importing C<-types>.
256             #pod
257             #pod =head2 C<-all>
258             #pod
259             #pod This import group will import C<-type>, C, and C.
260             #pod
261             #pod =cut
262              
263             my $prog_name;
264 31 100   31 1 245 sub prog_name { @_ ? ($prog_name = shift) : $prog_name }
265              
266             BEGIN {
267             # grab this before someone decides to change it
268 2     2   162 prog_name(File::Basename::basename($0));
269             }
270              
271 2     2   990 use Sub::Exporter::Util ();
  2         28840  
  2         160  
272             use Sub::Exporter 0.972 -setup => {
273             exports => [
274             describe_options => \'_build_describe_options',
275             q(prog_name),
276 2         33 @{ $Params::Validate::EXPORT_TAGS{types} }
277             ],
278             groups => [
279             default => [ qw(describe_options) ],
280             types => $Params::Validate::EXPORT_TAGS{types},
281 2         8 ],
282 2     2   16 };
  2         38  
283              
284             my %CONSTRAINT = (
285             implies => \&_mk_implies,
286             required => { optional => 0 },
287             only_one => \&_mk_only_one,
288             );
289              
290             our $MungeOptions = 1;
291              
292             our $TERM_WIDTH;
293             {
294             $TERM_WIDTH = $ENV{COLUMNS} || 80;
295              
296             # So, this was the old code:
297             #
298             # if (eval { require Term::ReadKey; 1 }) {
299             # my ($width) = Term::ReadKey::GetTerminalSize();
300             # $TERM_WIDTH = $width;
301             # } else {
302             # $TERM_WIDTH = $ENV{COLUMNS} || 80;
303             # }
304             #
305             # ...but the problem is that Term::ReadKey will carp when it can't get an
306             # answer, it can't be trivially made to keep quiet. (I decline to stick a
307             # local $SIG{__WARN__} here, as it's too heavy a hammer.) With the new (as
308             # of 2021-03) formatting code, using the full width is less of an issue,
309             # anyway.
310             }
311              
312             sub _nohidden {
313 58     58   109 return grep { ! $_->{constraint}->{hidden} } @_;
  202         542  
314             }
315              
316             sub _expand {
317 35     35   57 my @expanded;
318              
319 35         72 for my $opt (@_) {
320 101 100 100     670 push @expanded, {
    100 100        
      50        
321             spec => $opt->[0] || '',
322             desc => @$opt > 1 ? $opt->[1] : 'spacer',
323             constraint => $opt->[2] || {},
324              
325             # if @$_ is 0 then we got [], a spacer
326             name => @$opt ? _munge((split /[:=|!+]/, $opt->[0] || '')[0]) : '',
327             };
328             }
329              
330 35         93 return @expanded;
331             }
332              
333             my %HIDDEN = (
334             hidden => 1,
335             );
336              
337             my $SPEC_RE = qr{(?:[:=][0-9\w\+]+[%@]?(\{[0-9]*,[0-9]*\})?|[!+])$};
338             sub _strip_assignment {
339 164     164   299 my ($self, $str) = @_;
340              
341 164         846 (my $copy = $str) =~ s{$SPEC_RE}{};
342              
343 164 100       367 if (wantarray) {
344 78         143 my $len = length $copy;
345 78   50     181 my $assignment = substr($str, $len) // q{};
346              
347 78         256 return ($copy, $assignment);
348             }
349 86         201 return $copy;
350             }
351              
352             # This is here only to deal with people who were calling this fully-qualified
353             # without importing. Sucks to them! -- rjbs, 2009-08-21
354             sub describe_options {
355 0     0 1 0 my $sub = __PACKAGE__->_build_describe_options(describe_options => {} => {});
356 0         0 $sub->(@_);
357             }
358              
359 29     29 1 70 sub usage_class { 'Getopt::Long::Descriptive::Usage' }
360              
361             sub _build_describe_options {
362 2     2   501 my ($class) = @_;
363              
364             sub {
365 29     29   18707 my $format = shift;
366 29 50 33     175 my $arg = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {};
367 29         84 my @opts;
368              
369             my %parent_of;
370              
371             # special casing
372             # wish we had real loop objects
373 29         0 my %method_map;
374 29         74 for my $opt (_expand(@_)) {
375 91 100       241 $method_map{ $opt->{name} } = undef unless $opt->{desc} eq 'spacer';
376              
377 91 100       184 if (ref($opt->{desc}) eq 'ARRAY') {
378 5         13 $opt->{constraint}->{one_of} = delete $opt->{desc};
379 5         12 $opt->{desc} = 'hidden';
380             }
381              
382 91 100       192 if ($HIDDEN{$opt->{desc}}) {
383 6         13 $opt->{constraint}->{hidden}++;
384             }
385              
386 91 100       160 if ($opt->{constraint}->{one_of}) {
387 6         8 for my $one_opt (_expand(
388 6         18 @{delete $opt->{constraint}->{one_of}}
389             )) {
390 10         25 $parent_of{$one_opt->{name}} = $opt->{name};
391             $one_opt->{constraint}->{implies}
392 10         28 ->{$opt->{name}} = $one_opt->{name};
393 10         17 for my $wipe (qw(required default)) {
394 20 50       44 if ($one_opt->{constraint}->{$wipe}) {
395 0         0 carp "'$wipe' constraint does not make sense in sub-option";
396 0         0 delete $one_opt->{constraint}->{$wipe};
397             }
398             }
399 10         21 $one_opt->{constraint}->{one_of} = $opt->{name};
400 10         16 push @opts, $one_opt;
401              
402             # Ensure that we generate accessors for all one_of sub-options
403             $method_map{ $one_opt->{name} } = undef
404 10 50       30 unless $one_opt->{desc} eq 'spacer';
405             }
406             }
407              
408 91 100 100     189 if ($opt->{constraint}{shortcircuit}
409             && exists $opt->{constraint}{default}
410             ) {
411 1         221 carp('option "' . $opt->{name} . q[": 'default' does not make sense for shortcircuit options]);
412             }
413              
414 91         290 push @opts, $opt;
415             }
416              
417 29 50 33     55 my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] };
  29         148  
418 29 50       71 if ($arg->{getopt}) {
419 0         0 warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n";
420             }
421              
422 29 50       77 push @go_conf, "bundling" unless grep { /bundling/i } @go_conf;
  0         0  
423 29 50       60 push @go_conf, "no_auto_help" unless grep { /no_auto_help/i } @go_conf;
  29         107  
424             push @go_conf, "no_ignore_case"
425 29 50       52 unless grep { /no_ignore_case/i } @go_conf;
  58         132  
426              
427             # not entirely sure that all of this (until the Usage->new) shouldn't be
428             # moved into Usage -- rjbs, 2009-08-19
429              
430             # all specs including hidden
431             my @getopt_specs =
432 94         181 map { $_->{spec} }
433 29         49 grep { $_->{desc} ne 'spacer' }
  101         191  
434             @opts;
435              
436             my @specs =
437 86         152 map { $_->{spec} }
438 29         66 grep { $_->{desc} ne 'spacer' }
  93         174  
439             _nohidden(@opts);
440              
441             my @options =
442 86         188 map { split /\|/ }
443 29         62 map { scalar __PACKAGE__->_strip_assignment($_) }
  86         180  
444             @specs;
445              
446 29         60 my %opt_count;
447 29         118 $opt_count{$_}++ for @options;
448 29         77 my @redundant = sort grep {; $opt_count{$_} > 1 } keys %opt_count;
  101         208  
449              
450 29 100       85 warn "Getopt::Long::Descriptive was configured with these ambiguous options: @redundant\n"
451             if @redundant;
452              
453             my $short = join q{},
454 23 50       52 sort { lc $a cmp lc $b or $a cmp $b }
455 29         61 grep { /^.$/ }
  102         262  
456             @options;
457              
458 29         142 my $long = grep /\b[^|]{2,}/, @specs;
459              
460 29 100       77 my %replace = (
    100          
461             "%" => "%",
462             "c" => prog_name,
463             "o" => join(q{ },
464             ($short ? "[-$short]" : ()),
465             ($long ? "[long options...]" : ())
466             ),
467             );
468              
469 29         167 (my $str = $format) =~ s<%(.)><
470 42   33     207 $replace{$1}
471             // Carp::croak("unknown sequence %$1 in first argument to describe_options")
472             >ge;
473              
474 29         125 $str =~ s/[\x20\t]{2,}/ /g;
475              
476             my $usage = $class->usage_class->new({
477             options => [ _nohidden(@opts) ],
478             leader_text => $str,
479             show_defaults => $arg->{show_defaults},
480 29         78 });
481              
482 29         144 Getopt::Long::Configure(@go_conf);
483              
484 29         1609 my %return;
485 29 50       63 $usage->die unless GetOptions(\%return, grep { length } @getopt_specs);
  94         215  
486 29         8969 my @given_keys = keys %return;
487              
488 29         74 for my $opt (keys %return) {
489 28         59 my $newopt = _munge($opt);
490 28 100       71 next if $newopt eq $opt;
491 1         4 $return{$newopt} = delete $return{$opt};
492             }
493              
494             # ensure that shortcircuit options are handled first
495 29         59 for my $copt (
496             sort { ($b->{constraint}{shortcircuit} || 0)
497 119   100     502 <=> ($a->{constraint}{shortcircuit} || 0)
      50        
498 101         226 } grep { $_->{constraint} } @opts
499             ) {
500 76         137 delete $copt->{constraint}->{hidden};
501 76         120 my $is_shortcircuit = delete $copt->{constraint}{shortcircuit};
502 76         135 my $name = $copt->{name};
503             my $new = _validate_with(
504             name => $name,
505             params => \%return,
506             spec => $copt->{constraint},
507 76         213 opts => \@opts,
508             usage => $usage,
509             given_keys => \@given_keys,
510             parent_of => \%parent_of,
511             );
512 73 50 66     278 next unless defined $new || exists $return{$name};
513 28         56 $return{$name} = $new;
514              
515 28 100       64 if ($is_shortcircuit) {
516 3         9 %return = ($name => $return{$name});
517 3         10 last;
518             }
519             }
520              
521             my $opt_obj = Getopt::Long::Descriptive::Opts->___new_opt_obj({
522             values => { %method_map, %return },
523 26         151 given => { map {; $_ => 1 } @given_keys },
  26         113  
524             });
525              
526 26         237 return($opt_obj, $usage);
527             }
528 2         23 }
529              
530             sub _munge {
531 125     125   262 my ($opt) = @_;
532 125 50       236 return $opt unless $MungeOptions;
533 125         215 $opt = lc($opt);
534 125         201 $opt =~ tr/-/_/;
535 125         416 return $opt;
536             }
537              
538             sub _validate_with {
539 76     76   1541 my (%arg) = validate(@_, {
540             name => 1,
541             params => 1,
542             spec => 1,
543             opts => 1,
544             usage => 1,
545             given_keys => 1,
546             parent_of => 1,
547             });
548              
549 76         441 my $spec = $arg{spec};
550 76         113 my %pvspec;
551 76         102 for my $ct (keys %{$spec}) {
  76         224  
552 38 100 100     145 if ($CONSTRAINT{$ct} and ref $CONSTRAINT{$ct} eq 'CODE') {
553 11   50     46 $pvspec{callbacks} ||= {};
554             $pvspec{callbacks} = {
555 11         34 %{$pvspec{callbacks}},
556             $CONSTRAINT{$ct}->(
557             $arg{name},
558             $spec->{$ct},
559             $arg{params},
560             $arg{opts},
561 11         18 ),
562             };
563             } else {
564             %pvspec = (
565             %pvspec,
566 27 100       114 $CONSTRAINT{$ct} ? %{$CONSTRAINT{$ct}} : ($ct => $spec->{$ct}),
  8         26  
567             );
568             }
569             }
570              
571 76 100       201 $pvspec{optional} = 1 unless exists $pvspec{optional};
572              
573             # we need to implement 'default' by ourselves sometimes
574             # because otherwise the implies won't be checked/executed
575             # XXX this should be more generic -- we'll probably want
576             # other callbacks to always run, too
577 76 50 100     281 if (!defined($arg{params}{$arg{name}})
      66        
578             && $pvspec{default}
579             && $spec->{implies}) {
580              
581 0         0 $arg{params}{$arg{name}} = delete $pvspec{default};
582             }
583              
584 76         112 my %p;
585 76         139 my $ok = eval {
586             %p = validate_with(
587             params => [
588 76         1435 %{$arg{params}},
589             '-given_keys', $arg{given_keys},
590             '-parent_of', $arg{parent_of},
591             ],
592             spec => { $arg{name} => \%pvspec },
593             allow_extra => 1,
594             on_fail => sub {
595 3     3   8 my $fail_msg = shift;
596 3         19 Getopt::Long::Descriptive::_PV_Error->throw($fail_msg);
597             },
598 76         113 );
599 73         533 1;
600             };
601              
602 76 100       199 if (! $ok) {
603 3         6 my $error = $@;
604 3 50 33     33 if (
605             Scalar::Util::blessed($error)
606             && $error->isa('Getopt::Long::Descriptive::_PV_Error')
607             ) {
608 3         12 $arg{usage}->die({ pre_text => $error->error . "\n" });
609             }
610              
611 0         0 die $@;
612             }
613              
614 73         322 return $p{$arg{name}};
615             }
616              
617             # scalar: single option = true
618             # arrayref: multiple options = true
619             # hashref: single/multiple options = given values
620             sub _norm_imply {
621 11     11   22 my ($what) = @_;
622              
623 11 100       29 return { $what => 1 } unless my $ref = ref $what;
624              
625 9 50       26 return $what if $ref eq 'HASH';
626 0 0       0 return { map { $_ => 1 } @$what } if $ref eq 'ARRAY';
  0         0  
627              
628 0         0 die "can't imply: $what";
629             }
630              
631             sub _mk_implies {
632 11     11   22 my $name = shift;
633 11         23 my $what = _norm_imply(shift);
634 11         17 my $param = shift;
635 11         19 my $opts = shift;
636              
637 11         25 for my $implied (keys %$what) {
638             die("option specification for $name implies nonexistent option $implied\n")
639 11 50   29   72 unless first { $_->{name} eq $implied } @$opts
  29         76  
640             }
641              
642 11         29 my $whatstr = join(q{, }, map { "$_=$what->{$_}" } keys %$what);
  11         47  
643              
644             return "$name implies $whatstr" => sub {
645 6     6   18 my ($pv_val, $rest) = @_;
646              
647             # negatable options will be 0 here, which is ok.
648 6 50       31 return 1 unless defined $pv_val;
649              
650 6         27 while (my ($key, $val) = each %$what) {
651             # Really, this should be called "-implies" and should include all implies
652             # relationships, but they'll have to get handled by setting conflicts.
653 6         15 my $parent = $rest->{'-parent_of'}{$name};
654             my @siblings = $parent
655             ? (grep {; defined $rest->{'-parent_of'}{$_}
656 6 100       31 && $rest->{'-parent_of'}{$_} eq $parent }
657 6 100       13 @{ $rest->{'-given_keys'} })
  4         11  
658             : ();
659              
660 6 100       16 if (@siblings > 1) {
661 1         16 die "these options conflict; each wants to set the $parent: @siblings\n";
662             }
663              
664 5 50 66     21 if ( exists $param->{$key}
      66        
665             and $param->{$key} ne $val
666 1         5 and grep {; $_ eq $key } @{ $rest->{'-given_keys'} }
  1         3  
667             ) {
668 0         0 die(
669             "option specification for $name implies that $key should be "
670             . "set to '$val', but it is '$param->{$key}' already\n"
671             );
672             }
673 5         18 $param->{$key} = $val;
674             }
675              
676 5         42 return 1;
677 11         80 };
678             }
679              
680             sub _mk_only_one {
681 0     0   0 die "unimplemented";
682             }
683              
684             {
685             package
686             Getopt::Long::Descriptive::_PV_Error;
687 3     3   29 sub error { $_[0]->{error} }
688             sub throw {
689 3     3   9 my ($class, $error_msg) = @_;
690 3         10 my $self = { error => $error_msg };
691 3         6 bless $self, $class;
692 3         19 die $self;
693             }
694             }
695              
696             #pod =head1 CUSTOMIZING
697             #pod
698             #pod Getopt::Long::Descriptive uses L to build and
699             #pod export the C routine. By writing a new class that extends
700             #pod Getopt::Long::Descriptive, the behavior of the constructed C
701             #pod routine can be changed.
702             #pod
703             #pod The following methods can be overridden:
704             #pod
705             #pod =head2 usage_class
706             #pod
707             #pod my $class = Getopt::Long::Descriptive->usage_class;
708             #pod
709             #pod This returns the class to be used for constructing a Usage object, and defaults
710             #pod to Getopt::Long::Descriptive::Usage.
711             #pod
712             #pod =head1 SEE ALSO
713             #pod
714             #pod =for :list
715             #pod * L
716             #pod * L
717             #pod
718             #pod =cut
719              
720             1; # End of Getopt::Long::Descriptive
721              
722             __END__