File Coverage

lib/Getopt/ArgParse/Parser.pm
Criterion Covered Total %
statement 560 583 96.0
branch 271 320 84.6
condition 116 141 82.2
subroutine 37 38 97.3
pod 0 15 0.0
total 984 1097 89.7


line stmt bran cond sub pod time code
1             package Getopt::ArgParse::Parser;
2              
3 20     20   664906 use Moo;
  20         204014  
  20         91  
4              
5 20     20   34541 use Getopt::Long qw(GetOptionsFromArray);
  20         195694  
  20         92  
6 20     20   10377 use Text::Wrap;
  20         38128  
  20         899  
7 20     20   100 use Scalar::Util qw(blessed);
  20         26  
  20         1310  
8              
9 20     20   82 use File::Basename ();
  20         27  
  20         248  
10 20     20   5278 use Getopt::ArgParse::Namespace;
  20         36  
  20         849  
11              
12             use constant {
13 20         112225 TYPE_UNDEF => 0,
14             TYPE_SCALAR => 1,
15             TYPE_ARRAY => 2,
16             TYPE_COUNT => 3,
17             TYPE_PAIR => 4, # key=value pair
18             TYPE_BOOL => 5,
19              
20             CONST_TRUE => 1,
21             CONST_FALSE => 0,
22              
23             # Export these?
24             ScalarArg => 'scalar',
25             ArrayArg => 'Array',
26             PairArg => 'Pair',
27             CountArg => 'Count',
28             BoolArg => 'Bool',
29              
30             # Internal
31             ERROR_PREFIX => 'Getopt::ArgParse: ',
32             PRINT_REQUIRED => 1,
33             PRINT_OPTIONAL => 2,
34 20     20   81 };
  20         23  
35              
36             # Allow customization
37             # default actions
38             my %Action2ClassMap = (
39             '_store' => 'Getopt::ArgParse::ActionStore',
40             '_append' => 'Getopt::ArgParse::ActionAppend',
41             '_count' => 'Getopt::ArgParse::ActionCount',
42             # Not supported - Maybe in the future
43             # '_help' => 'Getopt::ArgParse::ActionHelp',
44             # '_version' => 'Getopt::ArgParse::ActionVersion',
45             );
46              
47             my %Type2ConstMap = (
48             '' => TYPE_UNDEF(),
49             'Scalar' => TYPE_SCALAR(),
50             'Array' => TYPE_ARRAY(),
51             'Count' => TYPE_COUNT(),
52             'Pair' => TYPE_PAIR(),
53             'Bool' => TYPE_BOOL(),
54             );
55              
56              
57             sub _croak {
58 38     38   321 die join('', @_, "\n");
59             }
60              
61             # Program name. Default $0
62              
63             has prog => ( is => 'rw', required => 1, default => sub { File::Basename::basename($0) }, );
64              
65             # short one
66             has help => ( is => 'rw', required => 1, default => sub { '' }, );
67              
68             # long one
69             has description => ( is => 'rw', required => 1, default => sub { '' }, );
70              
71             has epilog => ( is => 'rw', required => 1, default => sub { '' }, );
72              
73             has error_prefix => (is => 'rw', default => sub { ERROR_PREFIX() }, );
74              
75             has aliases => (is => 'ro', default => sub { [] }); # for subcommand only
76              
77             # namespace() - Read/write
78             # Contains the parsed results.
79             has namespace => (
80             is => 'rw',
81             isa => sub {
82             return undef unless $_[0]; # allow undef
83             my $class = blessed $_[0];
84             die 'namespace doesn\'t comform to the required interface'
85             unless $class && $class->can('set_attr') && $class->can('get_attr');
86             },
87             );
88              
89             # parent - Readonly
90             has parents => (
91             is => 'ro',
92             isa => sub {
93             my $parents = shift;
94             for my $parent (@$parents) {
95             my $parent_class = blessed $parent;
96             die 'parent is not a Getopt::ArgParse::Parser'
97             unless $parent_class && $parent_class->isa(__PACKAGE__);
98             }
99             },
100             default => sub { [] },
101             );
102              
103             # parser_configs - Read/write
104              
105             # The configurations that will be passed to Getopt::Long::Configure(
106             # $self->parser_configs ) when parse_args is invoked.
107             has parser_configs => ( is => 'rw', required => 1, default => sub { [] }, );
108              
109             # Behavioural properties
110             #
111             # Print usage message if help is no, by default. Turn this off by
112             # setting this to a false value
113             has print_usage_if_help => (is => 'ro', default => 1);
114              
115             # internal properties
116              
117             has _option_position => ( is => 'rw', required => 1, default => sub { 0 } );
118              
119             # The current subcommand the same as namespace->current_command
120             has _command => ( is => 'rw');
121              
122             # Sortby parameter. Used to determine if sorting by 'position' or by 'name'
123             has sortby => (
124             is => 'rw',
125             isa => sub {
126             die "$_[0] is not valid: valid options are: name, position" unless ($_[0] eq 'position' or $_[0] eq 'name');
127             },
128             default => $_[0] || 'position'
129             );
130              
131             sub BUILD {
132 62     62 0 461 my $self = shift;
133              
134 62         135 $self->{-option_specs} = {};
135 62         112 $self->{-position_specs} = {};
136              
137 62         150 $self->add_argument(
138             '--help', '-h',
139             type => 'Bool',
140             dest => 'help',
141             help => 'show this help message and exit',
142             reset => 1,
143             );
144              
145             # merge
146 62         44 for my $parent (@{$self->parents}) {
  62         999  
147 5         8 $self->copy($parent);
148             }
149             }
150              
151             #
152             sub _check_parent {
153 18     18   14 my $parent = shift;
154 18         37 my $parent_class = blessed $parent;
155 18 50 33     102 _croak 'Parent is not a Getopt::ArgParse::Parser'
156             unless $parent_class && $parent_class->isa(__PACKAGE__);
157             }
158              
159             sub copy {
160 5     5 0 6 my $self = shift;
161 5         3 my $parent = shift;
162              
163 5 50       10 _croak 'Parent is missing' unless $parent;
164 5         5 _check_parent($parent);
165              
166 5         6 $self->copy_args($parent);
167 5         13 $self->copy_parsers($parent);
168             }
169              
170             sub copy_args {
171 7     7 0 27 my $self = shift;
172 7         4 my $parent = shift;
173              
174 7 50       14 _croak 'Parent is missing' unless $parent;
175 7         10 _check_parent($parent);
176              
177 7         4 $self->add_arguments( @{ $parent->{-pristine_add_arguments} } );
  7         20  
178             }
179              
180             sub copy_parsers {
181 6     6 0 12 my $self = shift;
182 6         4 my $parent = shift;
183              
184 6 50       11 _croak 'Parent is missing' unless $parent;
185 6         8 _check_parent($parent);
186              
187 6 100       80 if (exists $parent->{-subparsers}) {
188 2         6 $self->add_subparsers(
189 2         2 @{$parent->{-pristine_add_subparsers}->[0]}
190             );
191              
192 2         3 for my $args (@{$parent->{-pristine_add_parser}}) {
  2         6  
193 6         14 my $command = $args->[0];
194 6 100       12 next if $command eq 'help';
195 4         42 $self->add_parser(
196             @$args,
197             parents => [ $parent->{-subparsers}{-parsers}{$command} ],
198             );
199             }
200             }
201             }
202              
203             #
204             # subcommands
205             #
206             sub add_subparsers {
207 16     16 0 1231 my $self = shift;
208              
209 16         14 push @{$self->{-pristine_add_subparsers}}, [ @_ ];
  16         68  
210              
211 16 100       63 _croak $self->error_prefix . 'Incorrect number of arguments' if scalar(@_) % 2;
212              
213 15         68 my $args = { @_ };
214              
215 15   100     61 my $title = (delete $args->{title} || 'subcommands') . ':';
216 15   100     54 my $description = delete $args->{description} || '';
217              
218 15 100       109 _croak $self->error_prefix . sprintf(
219             'Unknown parameters: %s',
220             join(',', keys %$args)
221             ) if keys %$args;
222              
223 14 100       39 if (exists $self->{-subparsers}) {
224 1         3 _croak $self->error_prefix . 'Subparsers already added';
225             }
226              
227 13         37 $self->{-subparsers}{-title} = $title;
228 13         29 $self->{-subparsers}{-description} = $description;
229 13         121 $self->{-subparsers}{-alias_map} = {};
230              
231 13         144 my $hp = $self->add_parser(
232             'help',
233             help => 'display help information about ' . $self->prog,
234             );
235              
236 13         153 $hp->add_arguments(
237             [
238             '--all', '-a',
239             help => 'Show the full usage',
240             type => 'Bool',
241             ],
242             [
243             'command',
244             help => 'Show the usage for this command',
245             dest => 'help_command',
246             nargs => 1,
247             ],
248             );
249              
250 13         34 return $self;
251             }
252              
253             # $command, aliases => [], help => ''
254             sub add_parser {
255 36     36 0 1316 my $self = shift;
256              
257 36 100       112 _croak $self->error_prefix . 'add_subparsers() is not called first' unless $self->{-subparsers};
258              
259 35         33 my $command = shift;
260              
261 35 100       55 _croak $self->error_prefix . 'Subcommand is empty' unless $command;
262              
263 34 100       69 _croak $self->error_prefix . 'Incorrect number of arguments' if scalar(@_) % 2;
264              
265 33 100       79 if (exists $self->{-subparsers}{-parsers}{$command}) {
266 1         5 _croak $self->error_prefix . "Subcommand $command already defined";
267             }
268              
269 32         55 my $args = { @_ };
270              
271 32   100     98 my $parents = delete $args->{parents} || [];
272 32         36 push @{ $self->{-pristine_add_parser} }, [ $command, %$args ];
  32         107  
273              
274 32 50       71 _croak $self->error_prefix . 'Add_subparsers() is not called first' unless $self->{-subparsers};
275              
276 32   100     78 my $help = delete $args->{help} || '';
277 32   100     92 my $description = delete $args->{description} || '';
278 32   100     95 my $aliases = delete $args->{aliases} || [];
279              
280 32 100       72 _croak $self->error_prefix . 'Aliases is not an arrayref'
281             if ref($aliases) ne 'ARRAY';
282              
283 31 100       56 _croak $self->error_prefix . sprintf(
284             'Unknown parameters: %s',
285             join(',', keys %$args)
286             ) if keys %$args;
287              
288 30         32 my $alias_map = {};
289              
290 30         47 for my $alias ($command, @$aliases) {
291 35 100       97 if (exists $self->{-subparsers}{-alias_map}{$alias}) {
292 1         7 _croak $self->error_prefix
293             . "Alias=$alias already used by command="
294             . $self->{-subparsers}{-alias_map}{$alias};
295             }
296             }
297              
298 29         94 $self->{-subparsers}{-alias_map}{$_} = $command for ($command, @$aliases);
299              
300 29         46 my $prog = $command;
301              
302             # $prog .= ' (' . join(', ', @$aliases) . ')' if @$aliases;
303              
304 29         59 $self->{-subparsers}{-aliases}{$command} = $aliases;
305 29         638 return $self->{-subparsers}{-parsers}{$command} = __PACKAGE__->new(
306             prog => $prog,
307             aliases => $aliases, # subcommand
308             help => $help,
309             parents => $parents,
310             description => $description,
311             error_prefix => $self->error_prefix,
312             print_usage_if_help => $self->print_usage_if_help,
313             );
314             }
315              
316 0     0 0 0 sub get_parser { $_[0]->_get_subcommand_parser(@_) }
317              
318             *add_arg = \&add_argument;
319              
320             *add_args = \&add_arguments;
321              
322             # add_arguments([arg_spec], [arg_spec1], ...)
323             # Add multiple arguments.
324             # Interface method
325             sub add_arguments {
326 22     22 0 41 my $self = shift;
327              
328 22         52 $self->add_argument(@$_) for @_;
329              
330 22         27 return $self;
331             }
332              
333             #
334             sub add_argument {
335 204     204 0 8979 my $self = shift;
336              
337 204 100       351 return unless @_; # mostly harmless
338             #
339             # FIXME: This is for merginng parent parents This is a dirty hack
340             # and should be done properly by merging internal specs
341             # and subcommand merging is missing
342             #
343 203         208 push @{ $self->{-pristine_add_arguments} }, [ @_ ];
  203         621  
344              
345 203         471 my ($name, $flags, $rest) = $self->_parse_for_name_and_flags([ @_ ]);
346              
347 203 100       418 _croak $self->error_prefix . 'Incorrect number of arguments' if scalar(@$rest) % 2;
348              
349 202 100       317 _croak $self->error_prefix . 'Empty option name' unless $name;
350              
351 201         431 my $args = { @$rest };
352              
353 201         151 my @flags = @{ $flags };
  201         295  
354              
355             ################
356             # nargs - positional only
357             ################
358             ################
359             # type
360             ################
361 201   100     484 my $type_name = delete $args->{type} || 'Scalar';
362 201 100       433 my $type = $Type2ConstMap{$type_name} if exists $Type2ConstMap{$type_name};
363 201 100       291 _croak $self->error_prefix . "Unknown type=$type_name" unless defined $type;
364              
365 200         204 my $nargs = delete $args->{nargs};
366              
367 200 100       258 if ( defined $nargs ) {
368 28 100       55 _croak $self->error_prefix . 'Nargs only allowed for positional options' if @flags;
369              
370 27 100 100     183 if ( $type != TYPE_PAIR
      100        
      100        
371             && $type != TYPE_ARRAY
372             && $nargs ne '1'
373             && $nargs ne '?'
374             ) {
375 3         6 $type = TYPE_ARRAY;
376             }
377             }
378              
379 199 100 100     870 if ($type == TYPE_COUNT) {
    100          
380 10 50       30 $args->{action} = '_count' unless defined $args->{action};
381 10 100       31 $args->{default} = 0 unless defined $args->{default};
382             } elsif ($type == TYPE_ARRAY || $type == TYPE_PAIR) {
383 23 50       63 $args->{action} = '_append' unless defined $args->{action};
384             } else {
385             # pass
386             }
387              
388             ################
389             # action
390             ################
391 199   100     466 my $action_name = delete $args->{action} || '_store';
392              
393 199 50       367 my $action = $Action2ClassMap{$action_name}
394             if exists $Action2ClassMap{$action_name};
395              
396 199 50       253 $action = $action_name unless $action;
397              
398             {
399 199         143 local $SIG{__WARN__};
  199         471  
400 199         292 local $SIG{__DIE__};
401              
402 199         8614 eval "require $action";
403              
404 199 50       846 _croak $self->error_prefix . "Cannot load $action for action=$action_name" if $@;
405             };
406              
407             ################
408             # split
409             ################
410 199         305 my $split = delete $args->{split};
411 199 50 66     484 if (defined $split && !$split && $split =~ /^ +$/) {
      33        
412 0         0 _croak $self->error_prefix . 'Cannot use whitespaces to split';
413             }
414              
415 199 50 100     386 if (defined $split && $type != TYPE_ARRAY && $type != TYPE_PAIR) {
      66        
416 0         0 _croak $self->error_prefix . 'Split only for Array and Pair';
417             }
418              
419             ################
420             # default
421             ################
422 199         168 my $default;
423 199 100       316 if (exists $args->{default}) {
424 20         32 my $val = delete $args->{default};
425              
426 20 100       79 if (ref($val) eq 'ARRAY') {
    100          
427 2         3 $default = $val;
428             } elsif (ref($val) eq 'HASH') {
429 5 100       16 _croak $self->error_prefix . 'HASH default only for type Pair'
430             if $type != TYPE_PAIR;
431 4         4 $default = $val;
432             } else {
433 13         23 $default = [ $val ];
434             }
435              
436 19 100       44 if ($type != TYPE_PAIR) {
437 15 100 100     84 if ($type != TYPE_ARRAY && scalar(@$default) > 1) {
438 1         6 _croak $self->error_prefix . 'Multiple default values for scalar type: $name';
439             }
440             }
441             }
442              
443             ################
444             # choices
445             ################
446 197   100     549 my $choices = delete $args->{choices} || undef;
447 197 50 100     401 if ( $choices
      66        
448             && ref($choices) ne 'CODE'
449             && ref($choices) ne 'ARRAY' )
450             {
451 0         0 _croak $self->error_prefix . "Must provide choices in an arrayref or a coderef";
452             }
453              
454 197   100     617 my $choices_i = delete $args->{choices_i} || undef;
455              
456 197 100 100     307 if ($choices && $choices_i) {
457 1         5 _croak $self->error_prefix . 'Not allow to specify choices and choices_i';
458             }
459              
460 196 100 100     368 if ( $choices_i
461             && ref($choices_i) ne 'ARRAY' )
462             {
463 1         4 _croak $self->error_prefix . "Must provide choices_i in an arrayref";
464             }
465              
466             ################
467             # required
468             ################
469 195   100     501 my $required = delete $args->{required} || '';
470              
471 195 100 100     477 if ($type == TYPE_BOOL || $type == TYPE_COUNT) {
472 117         132 $required = ''; # TYPE_BOOL and TYPE_COUNT will already have default values
473             }
474              
475             ################
476             # help
477             ################
478 195   100     424 my $help = delete $args->{help} || '';
479              
480             ################
481             # metavar
482             ################
483 195   33     623 my $metavar = delete $args->{metavar} || uc($name);
484              
485 195 100 100     450 $metavar = ''
486             if $type == TYPE_BOOL
487             || $action_name eq '_count';
488              
489             ################
490             # dest
491             ################
492 195   66     408 my $dest = delete $args->{dest} || $name;
493 195         248 $dest =~ s/-/_/g; # option-name becomes option_name
494              
495 195 100       313 if (@flags) {
496 153         123 while (my ($d, $s) = each %{$self->{-option_specs}}) {
  293         805  
497 141 100       216 if ($dest ne $d) {
498 125         133 for my $f (@flags) {
499 312         570 _croak $self->error_prefix . "Flag $f already used for a different option ($d)"
500 177 100       127 if grep { $f eq $_ } @{$s->{flags}};
  177         260  
501             }
502             }
503             }
504              
505 152 50       338 if (exists $self->{-position_specs}{$dest}) {
506 0         0 _croak $self->error_prefix . "Option dest=$dest already used by a positional argument";
507             }
508             } else {
509 42 100       132 if (exists $self->{-option_specs}{$dest}) {
510 1         5 _croak $self->error_prefix . "Option dest=$dest already used by an optional argument";
511             }
512             }
513              
514             # never modify existing ones so that the parent's structure will
515             # not be modified
516 193   100     1806 my $spec = {
517             name => $name,
518             flags => \@flags,
519             action => $action,
520             nargs => $nargs,
521             split => $split,
522             required => $required || '',
523             type => $type,
524             default => $default,
525             choices => $choices,
526             choices_i => $choices_i,
527             dest => $dest,
528             metavar => $metavar,
529             help => $help,
530             position => $self->{-option_position}++, # sort order
531             groups => [ '' ],
532             };
533              
534 193         169 my $specs;
535 193 100       238 if (@flags) {
536 152         198 $specs = $self->{-option_specs};
537             } else {
538 41         65 $specs = $self->{-position_specs};
539             }
540              
541             # reset
542 193 100       331 if (delete $args->{reset}) {
543 81 100       1198 $self->namespace->set_attr($spec->{dest}, undef) if $self->namespace;
544 81         8614 delete $specs->{$spec->{dest}};
545             }
546              
547 193 50       411 _croak $self->error_prefix . sprintf(
548             'Unknown spec: %s',
549             join(',', keys %$args)
550             ) if keys %$args;
551              
552             # type check
553 193 100       325 if (exists $specs->{$spec->{dest}}) {
554 3         32 _croak $self->error_prefix . sprintf(
555             'Redefine option %s without reset',
556             $spec->{dest},
557             );
558             }
559              
560             # override
561 190         246 $specs->{$spec->{dest}} = $spec;
562              
563             # specs changed, need to force to resort specs by groups
564 190 50       327 delete $self->{-groups} if $self->{-groups};
565              
566             # Return $self for chaining, $self->add_argument()->add_argument()
567             # or use add_arguments
568 190         620 return $self;
569             }
570              
571             sub _parse_for_name_and_flags {
572 203     203   156 my $self = shift;
573 203         181 my $args = shift;
574              
575 203         156 my ($name, @flags);
576             FLAG:
577 203         361 while (my $flag = shift @$args) {
578 463 100       672 if (substr($flag, 0, 1) eq '-') {
579 274         512 push @flags, $flag;
580             } else {
581 189         225 unshift @$args, $flag;
582 189         256 last FLAG;
583             }
584             }
585              
586             # It's a positional argument spec if there are no flags
587 203 100       338 $name = @flags ? $flags[0] : shift(@$args);
588 203         577 $name =~ s/^-+//g;
589              
590 203         436 return ( $name, \@flags, $args );
591             }
592              
593             #
594             # parse_args([@_])
595             #
596             # Parse @ARGV if called without passing arguments. It returns an
597             # instance of ArgParse::Namespace upon success
598             #
599             # Interface
600              
601             sub parse_args {
602 82     82 0 5669 my $self = shift;
603              
604 82 100       368 my @argv = scalar(@_) ? @_ : @ARGV;
605              
606 82         306 $self->{-saved_argv} = \@ARGV;
607 82         113 @ARGV = ();
608              
609 122         256 my @option_specs = sort {
610 82         406 $a->{position} <=> $b->{position}
611 82         120 } values %{$self->{-option_specs}};
612              
613 28         51 my @position_specs = sort {
614 82         209 $a->{position} <=> $b->{position}
615 82         81 } values %{$self->{-position_specs}};
616              
617 82         152 $self->{-argv} = \@argv;
618             # We still want to continue even if @argv is empty to allow:
619             # - namespace initialization
620             # - default values asssigned
621             # - post checks applied, e.g. required check
622              
623 82 100       1940 $self->namespace(Getopt::ArgParse::Namespace->new) unless $self->namespace;
624              
625 82         421 my $parsed_subcmd;
626 82         1187 $self->namespace->set_attr(current_command => undef);
627              
628             # If the first argument is a subcommand, it will parse for the
629             # subcommand
630 82 100 100     365 if (exists $self->{-subparsers} && scalar(@argv) && defined($argv[0]) && substr($argv[0], 0, 1) ne '-') {
      33        
      66        
631             # Subcommand must appear as the first argument
632             # or it will parse as the top command
633 11         20 my $cmd = shift @argv;
634 11         31 my $subparser = $self->_get_subcommand_parser($cmd);
635 11 100       31 _croak $self->error_prefix
636             . sprintf("%s is not a %s command. See help", $cmd, $self->prog)
637             unless $subparser;
638              
639 10         92 $parsed_subcmd = $self->_parse_subcommand($self->_command => $subparser);
640              
641 10         156 $self->namespace->set_attr(current_command => $self->_command);
642             }
643              
644 81 100       248 if (!$parsed_subcmd) {
645 71 50       222 $self->_parse_optional_args(\@option_specs) if @option_specs;
646 64 100       166 $self->_parse_positional_args(\@position_specs) if @position_specs;
647              
648 56 100 100     878 if ($self->print_usage_if_help() && $self->namespace->get_attr('help')) {
649 1         3 $self->print_usage();
650 1         77 exit(0);
651             }
652             } else {
653 10 100 100     81 if ($self->print_usage_if_help() && $self->_command() eq 'help') {
654 2 100       28 if ($self->namespace->get_attr('help_command')) {
655 1         3 $self->print_command_usage();
656 1         82 exit(0);
657             } else {
658 1         2 $self->print_usage();
659 1         84 exit(0);
660             }
661             }
662             }
663              
664             # Return value
665 63         1003 return $self->namespace;
666             }
667              
668             sub _get_subcommand_parser {
669 13     13   17 my $self = shift;
670 13         12 my $alias = shift;
671              
672 13 50       25 return unless $alias;
673              
674 13 100       59 my $command = $self->{-subparsers}{-alias_map}{$alias}
675             if exists $self->{-subparsers}{-alias_map}{$alias};
676              
677 13 100       23 return unless $command;
678              
679 12         57 $self->_command($command);
680             # The subcommand parser must exist if the alias is mapped
681 12         26 return $self->{-subparsers}{-parsers}{$command};
682             }
683              
684             sub _parse_subcommand {
685 10     10   14 my $self = shift;
686 10         12 my ($cmd, $subparser) = @_;
687              
688 10         167 $subparser->namespace($self->namespace);
689 10         82 $subparser->parse_args(@{$self->{-argv}});
  10         63  
690              
691 10         81 $self->{-argv} = $subparser->{-argv};
692              
693 10         17 return 1;
694             }
695              
696             #
697             # After each call of parse_args(), call this to retrieve any
698             # unconsumed arguments
699             # Interface call
700             #
701             sub argv {
702 1 50   1 0 1 @{ $_[0]->{-argv} || [] };
  1         7  
703             }
704              
705             sub _parse_optional_args {
706 71     71   85 my $self = shift;
707 71         69 my $specs = shift;
708 71         123 my $options = {};
709 71         78 my $dest2spec = {};
710              
711 71         120 for my $spec ( @$specs ) {
712 158         143 my @values;
713 158         249 $dest2spec->{$spec->{dest}} = $self->_get_option_spec($spec);
714 158 100 100     985 if ( $spec->{type} == TYPE_ARRAY
      100        
      100        
715             || $spec->{type} == TYPE_COUNT
716             || $spec->{type} == TYPE_PAIR
717             || $spec->{type} == TYPE_SCALAR
718             ) {
719 66         43 my @values;
720 66         138 $options->{ $dest2spec->{$spec->{dest}} } = \@values;
721             } else {
722 92         70 my $value;
723 92         195 $options->{ $dest2spec->{$spec->{dest}} } = \$value;
724             }
725             }
726              
727 71         81 Getopt::Long::Configure( @{ $self->parser_configs });
  71         412  
728              
729 71         637 my (@warns, $result);
730              
731 71         67 eval {
732 71     2   404 local $SIG{__WARN__} = sub { push @warns, @_ };
  2         425  
733 71         192 local $SIG{__DIE__};
734              
735 71         309 $result = GetOptionsFromArray( $self->{-argv}, %$options );
736              
737 71         16197 1;
738             };
739              
740             # die on errors
741 71 50       154 _croak $self->error_prefix, $@ if $@;
742              
743 71 100       116 _croak $self->error_prefix, @warns if @warns;
744              
745 69 50       139 _croak $self->error_prefix, 'Failed to parse for options' if !$result;
746              
747 69         150 Getopt::Long::Configure('default');
748              
749 69         1440 $self->_post_parse_processing($specs, $options, $dest2spec);
750              
751 66         170 $self->_apply_action($specs, $options, $dest2spec);
752              
753 65         145 $self->_post_apply_processing($specs, $options, $dest2spec);
754             }
755              
756             sub _parse_positional_args {
757 32     32   34 my $self = shift;
758 32         27 my $specs = shift;
759              
760             # short-circuit it if it's for help
761 32 100       440 return if $self->namespace->get_attr('help');
762              
763 31         41 my $options = {};
764 31         37 my $dest2spec = {};
765              
766 31         46 for my $spec (@$specs) {
767 53         93 $dest2spec->{$spec->{dest}} = $spec->{dest};
768 53         48 my @values = ();
769             # Always assigne values to an option
770 53         91 $options->{$spec->{dest}} = \@values;
771             }
772              
773             POSITION_SPEC:
774 31         46 for my $spec (@$specs) {
775 53         61 my $values = $options->{$spec->{dest}};
776              
777 53 50       85 if ($spec->{type} == TYPE_BOOL) {
778 0         0 _croak $self->error_prefix . 'Bool not allowed for positional arguments';
779             }
780              
781 53         42 my $number = 1;
782 53 100       95 my $nargs = defined $spec->{nargs} ? $spec->{nargs} : 1;
783 53 100       79 if (defined $spec->{nargs}) {
784 32 100       148 if ($nargs eq '?') {
    100          
    100          
    100          
785 5         8 $number = 1;
786             } elsif ($nargs eq '+') {
787 3 100       4 _croak $self->error_prefix . "Too few arguments: narg='+'" unless @{$self->{-argv}};
  3         11  
788 2         2 $number = scalar @{$self->{-argv}};
  2         4  
789             } elsif ($nargs eq '*') { # remainder
790 3         3 $number = scalar @{$self->{-argv}};
  3         6  
791             } elsif ($nargs !~ /^\d+$/) {
792 1         7 _croak $self->error_prefix . 'Invalid nargs:' . $nargs;
793             } else {
794 20         22 $number = $nargs;
795             }
796             }
797              
798 51 100       38 push @$values, splice(@{$self->{-argv}}, 0, $number) if @{$self->{-argv}};
  37         72  
  51         120  
799              
800             # If no values, let it pass for required checking
801             # If there are values, make sure there is the right number of
802             # values
803 51 100 100     210 if (scalar(@$values) && scalar(@$values) != $number) {
804 3         24 _croak($self->error_prefix . sprintf(
805             'Too few arguments for %s: expected:%d,actual:%d',
806             $spec->{dest}, $number, scalar(@$values),
807             )
808             );
809             }
810             }
811              
812 26         52 $self->_post_parse_processing($specs, $options, $dest2spec);
813              
814 26         45 $self->_apply_action($specs, $options, $dest2spec);
815              
816 26         51 $self->_post_apply_processing($specs, $options, $dest2spec);
817             }
818              
819             #
820             sub _post_parse_processing {
821 95     95   94 my $self = shift;
822 95         99 my ($option_specs, $options, $dest2spec) = @_;
823              
824             #
825 95         124 for my $spec ( @$option_specs ) {
826 198         249 my $values = $options->{ $dest2spec->{$spec->{dest}} };
827              
828 198 50       255 if (defined($values)) {
829 198 100       315 if (ref $values eq 'SCALAR') {
830 90 100       136 if (defined($$values)) {
831 11         20 $values = [ $$values ];
832             } else {
833 79         114 $values = [];
834             }
835             }
836             } else {
837 0         0 $values = [];
838             }
839              
840 198         255 $options->{ $dest2spec->{$spec->{dest}} } = $values;
841              
842             # default
843 198 100 100     3196 if (!defined($self->namespace->get_attr($spec->{dest}))
      100        
844             && scalar(@$values) < 1
845             && defined($spec->{default}) )
846             {
847 8 100       40 if ($spec->{type} == TYPE_COUNT) {
    100          
    100          
848 1         14 $self->namespace->set_attr($spec->{dest}, @{$spec->{default}});
  1         6  
849             } elsif ($spec->{type} == TYPE_BOOL) {
850 1         16 $self->namespace->set_attr($spec->{dest}, @{$spec->{default}});
  1         5  
851             } elsif ($spec->{type} == TYPE_PAIR) {
852 2         27 $self->namespace->set_attr($spec->{dest}, $spec->{default});
853             } else {
854 4         7 push @$values, @{$spec->{default}};
  4         7  
855             }
856             }
857              
858             # split and expand
859             # Pair are processed here as well
860 198 100       338 if ( my $delimit = $spec->{split} ) {
861 5         4 my @expanded;
862 5         6 for my $v (@$values) {
863 12 100       26 push @expanded,
864             map {
865 4         13 $spec->{type} == TYPE_PAIR ? { split('=', $_) } : $_
866             } split($delimit, $v);
867             }
868              
869 5         8 $options->{ $dest2spec->{$spec->{dest} } } = \@expanded;
870             } else {
871             # Process PAIR only
872 193 100       304 if ($spec->{type} == TYPE_PAIR) {
873 6         25 $options->{ $dest2spec->{$spec->{dest} } }
874 5         12 = [ map { { split('=', $_) } } @$values ];
875             }
876             }
877              
878             # choices
879 198 100       266 if ( $spec->{choices} ) {
880 5 100       10 if (ref($spec->{choices}) eq 'CODE') {
881 2         2 for my $v (@$values) {
882 2         5 $spec->{choices}->($v);
883             }
884             } else {
885 9 50       21 my %choices =
886 3         5 map { defined($_) ? $_ : '_undef' => 1 }
887 3         2 @{$spec->{choices}};
888              
889             VALUE:
890 3         7 for my $v (@$values) {
891 2 50       4 my $k = defined($v) ? $v : '_undef';
892 2 100       6 next VALUE if exists $choices{$k};
893              
894 1         8 _croak $self->error_prefix . sprintf(
895             "Option %s value %s not in choices: [ %s ]",
896 1         5 $spec->{dest}, $v, join( ', ', @{ $spec->{choices} } ),
897             );
898             }
899             }
900             }
901              
902 196 100       404 if ( $spec->{choices_i} ) {
903 6 50       15 my %choices =
904 3         4 map { defined($_) ? uc($_) : '_undef' => 1 }
905 3         4 @{$spec->{choices_i}};
906              
907             VALUE:
908 3         6 for my $v (@$values) {
909 3 50       5 my $k = defined($v) ? uc($v) : '_undef';
910 3 100       9 next VALUE if exists $choices{$k};
911              
912 1         6 _croak $self->error_prefix . sprintf(
913             "Option %s value %s not in choices: [ %s ] (case insensitive)",
914 1         3 $spec->{dest}, $v, join( ', ', @{ $spec->{choices_i} } ),
915             );
916             }
917             }
918             }
919              
920 92         105 return '';
921             }
922              
923             sub _apply_action {
924 92     92   86 my $self = shift;
925 92         91 my ($specs, $options, $dest2spec) = @_;
926              
927 92         120 for my $spec (@$specs) {
928             # Init
929             # We want to preserve already set attributes if the namespace
930             # is passed in.
931             #
932             # This is because one may want to load configs from a file
933             # into a namespace and then use the same namespace for parsing
934             # configs from command line.
935             #
936 189 100       2591 $self->namespace->set_attr($spec->{dest}, undef)
937             unless defined($self->namespace->get_attr($spec->{dest}));
938              
939 189         2478 my $error = $spec->{action}->apply(
940             $spec,
941             $self->namespace,
942             $options->{ $dest2spec->{$spec->{dest}} },
943             $spec->{name},
944             );
945              
946 189 100       339 _croak $self->error_prefix . $error if $error;
947             }
948              
949 91         126 return '';
950             }
951              
952             sub _post_apply_processing {
953 91     91   74 my $self = shift;
954 91         98 my ($specs, $options, $dest2spec) = @_;
955              
956             #
957             # required is checked after applying actions
958             # This is because required checking is bypassed if help is on
959             #
960 91         127 for my $spec (@$specs) {
961 186         2380 my $v = $self->namespace->get_attr($spec->{dest});
962              
963             # required
964 186 100 100     810 if ( $spec->{required} && not $self->namespace->get_attr('help') ) {
965 15         15 my $has_v;
966 15 100       35 if ($spec->{type} == TYPE_ARRAY) {
    50          
967 6         10 $has_v = @$v;
968             } elsif ($spec->{type} == TYPE_PAIR) {
969 0         0 $has_v = scalar(keys %$v);
970             } else {
971 9         12 $has_v = defined $v;
972             }
973              
974 15 100       66 _croak $self->error_prefix . sprintf("Option %s is required\n", $spec->{dest}) unless $has_v;
975             }
976             }
977             }
978              
979             # interface
980             sub print_usage {
981 3     3 0 8 my $self = shift;
982              
983 3         16 my $usage = $self->format_usage();
984              
985 3         243 print STDERR $_, "\n" for @$usage;
986             }
987              
988             # interface
989             sub print_command_usage {
990 1     1 0 2 my $self = shift;
991 1   33     18 my $command = shift
992             || $self->namespace->get_attr('help_command')
993             || $self->namespace->get_attr('current_command'); # running help command
994              
995 1         12 my $usage = $self->format_command_usage($command);
996 1 50       3 if ($usage) {
997 1         92 print STDERR $_, "\n" for @$usage;
998             } else {
999 0         0 print STDERR
1000             $self->error_prefix,
1001             sprintf('No help for %s. See help', $self->namespace->get_attr('help_command')),
1002             "\n";
1003             }
1004             }
1005              
1006             # Interface
1007             sub format_usage {
1008 5     5 0 6 my $self = shift;
1009              
1010 5 50       43 $self->_sort_specs_by_groups() unless $self->{-groups};
1011              
1012 5         10 my $old_wrap_columns = $Text::Wrap::columns;
1013              
1014 5         7 my @usage;
1015              
1016 5         39 my $aliases = $self->aliases;
1017 5         32 my $prog = $self->prog;
1018 5 100       36 $prog .= ' (' . join(', ', @$aliases) . ')' if @$aliases;
1019 5 100       50 if( $self->help ) {
1020 2         31 push @usage, wrap('', '', $prog. ': ' . $self->help);
1021 2         353 push @usage, '';
1022             }
1023              
1024 5         27 my ($help, $option_string) = $self->_format_group_usage();
1025 5         7 $Text::Wrap::columns = 80;
1026              
1027 5         23 my $header = sprintf(
1028             'usage: %s %s',
1029             $self->prog, $option_string
1030             );
1031              
1032 5         13 push @usage, wrap('', '', $header);
1033              
1034 5 100       843 if ($self->description) {
1035 2         12 my @lines = split("\n", $self->description);
1036              
1037 2         3 my @paragraphs;
1038              
1039 2         1 my $para = '';
1040 2         3 for my $line (@lines) {
1041 32 100       43 if ($line =~ /^\s*$/) {
1042 2         2 push @paragraphs, $para;
1043 2         3 $para = '';
1044             } else {
1045 30 100       37 $para .= ( $para ? ' ' : '' ) . $line;
1046             }
1047             }
1048              
1049 2         2 push @paragraphs, $para;
1050 2         3 for (@paragraphs) {
1051 4         1363 push @usage, '';
1052 4         6 push @usage, wrap('', '', $_);
1053             }
1054             }
1055              
1056 5         622 push @usage, @$help;
1057              
1058 5 100       17 if (exists $self->{-subparsers}) {
1059 3         11 push @usage, '';
1060 3         20 push @usage, wrap('', '', $self->{-subparsers}{-title});
1061 3 100       264 push @usage, wrap('', '', $self->{-subparsers}{-description}) if $self->{-subparsers}{-description};
1062              
1063 3         79 my $max = 12;
1064              
1065 3         5 for my $command ( keys %{$self->{-subparsers}{-parsers}} ) {
  3         26  
1066 6         8 my $len = length($command);
1067 6 50       15 $max = $len if $len > $max;
1068             }
1069              
1070 3         8 for my $command ( sort keys %{$self->{-subparsers}{-parsers}} ) {
  3         14  
1071 6         15 my $parser = $self->{-subparsers}{-parsers}{$command};
1072 6         22 my $tab_head = ' ' x ( $max + 2 );
1073              
1074 6         33 my @desc = split("\n", wrap('', '', $parser->help));
1075 6   50     642 my $desc = (shift @desc) || '';
1076 6         9 $_ = $tab_head . $_ for @desc;
1077 6         24 push @usage, sprintf(" %-${max}s %s", $command, join("\n", $desc, @desc));
1078             }
1079             }
1080              
1081 5 100       25 push @usage, '', wrap('', '', $self->epilog) if $self->epilog;
1082              
1083 5         82 $Text::Wrap::columns = $old_wrap_columns; # restore to original
1084              
1085 5         18 return \@usage;
1086             }
1087              
1088             sub format_command_usage {
1089 2     2 0 7 my $self = shift;
1090 2         2 my $alias = shift;
1091              
1092 2         5 my $subp = $self->_get_subcommand_parser($alias);
1093 2 50       5 return '' unless $subp;
1094              
1095 2         7 return $subp->format_usage();
1096             }
1097              
1098             # FIXME: Maybe we should remove this grouping thing
1099             sub _sort_specs_by_groups {
1100 5     5   4 my $self = shift;
1101              
1102 5         12 my $specs = $self->{-option_specs};
1103              
1104 5         5 for my $dest ( keys %{ $specs } ) {
  5         31  
1105 16         14 for my $group ( @{ $specs->{$dest}{groups} } ) {
  16         27  
1106 16         10 push @{ $self->{-groups}{$group}{-option} }, $specs->{$dest};
  16         75  
1107             }
1108             }
1109              
1110 5         14 $specs = $self->{-position_specs};
1111              
1112 5         8 for my $dest ( keys %{ $specs } ) {
  5         15  
1113 4         3 for my $group ( @{ $specs->{$dest}{groups} } ) {
  4         4  
1114 4         2 push @{ $self->{-groups}{$group}{-position} }, $specs->{$dest};
  4         10  
1115             }
1116             }
1117             }
1118              
1119             # This funtion finds the help argument and moves it
1120             # to the front of the optional parameters
1121             sub _move_help_after_required
1122             {
1123 5     5   7 my @option_spec = @_;
1124 5         5 my ($help, $i);
1125              
1126 5         8 $i=0;
1127 5         10 foreach my $element (@option_spec)
1128             {
1129 16 100       30 if ($element->{'position'} == 0)
1130             {
1131 5         12 $help = splice @option_spec, $i, 1;
1132 5         8 last;
1133             }
1134 11         7 $i++;
1135             }
1136              
1137 5         6 $i=0;
1138 5         73 foreach my $element (@option_spec)
1139             {
1140 8 100       15 if (!$element->{required})
1141             {
1142 5         7 splice @option_spec, $i, 0, $help;
1143 5         5 last;
1144             }
1145 3         2 $i++;
1146             }
1147 5         14 return @option_spec;
1148             }
1149              
1150             sub _format_group_usage {
1151 5     5   6 my $self = shift;
1152 5         18 my $group = '';
1153              
1154 5 50       16 unless ($self->{-groups}) {
1155 0         0 $self->_sort_specs_by_groups();
1156             }
1157              
1158 5         7 my $old_wrap_columns = $Text::Wrap::columns;
1159 5         13 $Text::Wrap::columns = 80;
1160              
1161 5         10 my @usage;
1162              
1163             my @option_specs;
1164             # When doing a sort by name, it puts all required parameters
1165             # first sorted by name, then all optional parameters sorted by name
1166 5 50       40 if ($self->sortby eq 'name')
    50          
1167             {
1168 0 0       0 @option_specs = sort {
1169 0 0       0 ($b->{required} cmp $a->{required} || $a->{name} cmp $b->{name})
1170 0         0 } @{ $self->{-groups}{$group}{-option} || [] };
1171 0         0 @option_specs = _move_help_after_required(@option_specs);
1172             }
1173             elsif($self->sortby eq 'position')
1174             {
1175 18 50       46 @option_specs = sort {
1176 5 50       102 ($b->{required} cmp $a->{required} || $b->{position} <=> $a->{position} )
1177 5         2872 } @{ $self->{-groups}{$group}{-option} || [] };
1178 5         16 @option_specs = _move_help_after_required(@option_specs);
1179             }
1180            
1181              
1182 16         52 my @flag_items = map {
1183 5         7 ($_->{required} ? '' : '[')
1184 16 100       25 . join('|', @{$_->{flags}})
    100          
1185             . ($_->{required} ? '' : ']')
1186             } @option_specs;
1187              
1188 2         4 my @position_specs = sort {
1189 5 100       44 $a->{position} <=> $b->{position}
1190 5         8 } @{ $self->{-groups}{$group}{-position} || [] };
1191              
1192 4 100       12 my @position_items = map {
    100          
1193 5         9 ($_->{required} ? '' : '[')
1194             . $_->{metavar}
1195             . ($_->{required} ? '' : ']')
1196             } @position_specs;
1197              
1198 5 100       22 my @subcommand_items = ('', '[]') if exists $self->{-subparsers};
1199              
1200 5 50       11 if ($group) {
1201 0   0     0 push @usage, wrap('', '', $group . ': ' . ($self->{-group_description}{$group} || '') );
1202             }
1203              
1204             # named arguments are arguments preceded by a hyphen as optional
1205             # vs. positional are too confusing.
1206 5         41 for my $spec_name ( [ \@position_specs, 'positional' ], [ \@option_specs, 'named' ]) {
1207 10         15 my ($specs, $spec_name) = @$spec_name;
1208 10         33 for my $type_name ( [ PRINT_REQUIRED, 'required'], [ PRINT_OPTIONAL, 'optional'] ) {
1209 20         21 my ($type, $type_name) = @$type_name;
1210 20         36 my $output = $self->_format_usage_by_spec($specs, $type);
1211 20 100       44 if (@$output) {
1212 10         14 push @usage, '';
1213             # Start a section: e.g. required positional arguments:
1214 10         16 push @usage, sprintf('%s %s arguments:', $type_name, $spec_name);
1215 10         24 push @usage, @$output;
1216             }
1217             }
1218             }
1219              
1220 5         8 $Text::Wrap::columns = $old_wrap_columns; # restore to original
1221              
1222 5         18 return ( \@usage, join(' ', @position_items, @flag_items, @subcommand_items) ) ;
1223             }
1224              
1225             sub _format_usage_by_spec {
1226 20     20   16 my $self = shift;
1227 20         16 my $specs = shift;
1228 20         70 my $print_type = shift;
1229              
1230 20 50       31 return unless $specs;
1231              
1232 20         17 my @usage;
1233 20         16 my $max = 10;
1234 20         15 my @item_help;
1235              
1236 20         26 SPEC: for my $spec ( @$specs ) {
1237 40 100 100     190 next SPEC if ($print_type == PRINT_OPTIONAL && $spec->{'required'})
      100        
      66        
1238             || ($print_type == PRINT_REQUIRED && !$spec->{'required'});
1239              
1240 20         19 my $item = $spec->{metavar};
1241              
1242 20 100       13 if (@{$spec->{flags}}) {
  20         39  
1243 16         45 $item = sprintf(
1244             "%s %s",
1245 16         13 join(', ', @{$spec->{flags}}),
1246             $spec->{metavar},
1247             );
1248             }
1249 20         15 my $len = length($item);
1250 20 100       33 $max = $len if $len > $max;
1251              
1252             # generate default string
1253 20         12 my $default = '';
1254 20         17 my $values = [];
1255              
1256 20 100       36 if (defined $spec->{default}) {
1257 3 100       11 if (ref $spec->{default} eq 'HASH') {
    50          
1258 1         1 while (my ($k, $v) = each %{$spec->{default}}) {
  3         8  
1259 2         4 push @$values, "$k=$v";
1260             }
1261             } elsif (ref $spec->{default} eq 'ARRAY') {
1262 2         3 $values = $spec->{default};
1263             } else {
1264 0         0 $values = [ $spec->{default} ];
1265             }
1266             }
1267              
1268 20 100       34 if (@$values) {
1269 3         5 $default = 'Default: ' . join(', ', @$values);
1270             }
1271              
1272             # generate choice string
1273 20         13 my $choices;
1274 20         92 my $case = '';
1275              
1276 20 50 33     59 if ($spec->{choices} && ref $spec->{choices} ne 'CODE') {
    50          
1277 0         0 $choices = $spec->{choices};
1278 0         0 $case = 'case sensitive';
1279             } elsif ($spec->{choices_i}) {
1280 0         0 $choices = $spec->{choices_i};
1281 0         0 $case = 'case insensitive';
1282             } else {
1283 20         15 $choices = undef;
1284             }
1285              
1286 20         14 my $choice_str = '';
1287 20 50       29 if ($choices) {
1288 0         0 $choice_str = 'Choices: [' . join(', ', @$choices) . '], ' . $case . "\n";
1289             }
1290              
1291 20 100 66     102 push @item_help, [
1292             $item,
1293             ($spec->{required} ? ' ' : '?'),
1294             join("\n", ($spec->{help} || 'This is option ' . $spec->{dest}), $choice_str . $default),
1295             ];
1296             }
1297              
1298 20         35 my $format = " %-${max}s %s %s";
1299 20         16 $Text::Wrap::columns = 60;
1300 20         21 for my $ih (@item_help) {
1301 20         19 my $item_len = length($ih->[0]);
1302             # The prefixed whitespace in subsequent lines in the wrapped
1303             # help string
1304 20         32 my $sub_tab = " " x ($max + 4 + 4 + 2);
1305 20         63 my @help = split("\n", wrap('', '', $ih->[2]));
1306              
1307 20   50     2196 my $help = (shift @help) || '' ; # head
1308 20         30 $_ = $sub_tab . $_ for @help; # tail
1309              
1310 20         77 push @usage, sprintf($format, $ih->[0], $ih->[1], join("\n", $help, @help));
1311             }
1312              
1313 20         65 return \@usage;
1314             }
1315              
1316             # translate option spec to the one accepted by
1317             # Getopt::Long::GetOptions
1318             sub _get_option_spec {
1319 158     158   118 my $self = shift;
1320 158         116 my $spec = shift;
1321              
1322 158         106 my @flags = @{ $spec->{flags} };
  158         294  
1323 158         674 $_ =~ s/^-+// for @flags;
1324 158         212 my $name = join('|', @flags);
1325 158         133 my $type = 's';
1326 158         123 my $desttype = '';
1327              
1328 158         120 my $optional_flag = '='; # not optional
1329              
1330 158 100       510 if ($spec->{type} == TYPE_SCALAR) {
    100          
    100          
    50          
    100          
    50          
1331 48         44 $desttype = '@';
1332             } elsif ($spec->{type} == TYPE_ARRAY) {
1333 10         8 $desttype = '@';
1334             } elsif ($spec->{type} == TYPE_PAIR) {
1335 4         4 $desttype = '@';
1336             } elsif ($spec->{type} == TYPE_UNDEF) {
1337 0         0 $optional_flag = ':';
1338             } elsif ($spec->{type} == TYPE_BOOL) {
1339 92         88 $type = '';
1340 92         75 $optional_flag = '';
1341 92         73 $desttype = '';
1342             } elsif ($spec->{type} == TYPE_COUNT) {
1343             # pass
1344 4         3 $type = '';
1345 4         3 $optional_flag = '';
1346 4         4 $desttype = '+';
1347             } else {
1348             # pass
1349             # should never be here
1350 0   0     0 _croak $self->error_prefix . 'Unknown type:' . ($spec->{type} || 'undef');
1351             }
1352              
1353 158         120 my $repeat = '';
1354              
1355 158         191 my $opt = join('', $name, $optional_flag, $type, $repeat, $desttype);
1356              
1357 158         344 return $opt;
1358             }
1359              
1360             1;
1361              
1362             __END__