1package CLI::Osprey::Role;
2use strict;
3use warnings;
4use Carp 'croak';
5use Path::Tiny ();
6use Scalar::Util qw(blessed);
7use Module::Runtime 'use_module';
8
9use CLI::Osprey::Descriptive;
10
11# ABSTRACT: Role for CLI::Osprey applications
12our $VERSION = '0.08'; # VERSION
13our $AUTHORITY = 'cpan:ARODLAND'; # AUTHORITY
14
15sub _osprey_option_to_getopt {
16  my ($name, %attributes) = @_;
17  my $getopt = join('|', grep defined, ($name, $attributes{short}));
18  $getopt .= '+' if $attributes{repeatable} && !defined $attributes{format};
19  $getopt .= '!' if $attributes{negatable};
20  $getopt .= '=' . $attributes{format} if defined $attributes{format};
21  $getopt .= '@' if $attributes{repeatable} && defined $attributes{format};
22  return $getopt;
23}
24
25sub _osprey_prepare_options {
26  my ($options, $config) = @_;
27
28  my @getopt;
29  my %abbreviations;
30  my %fullnames;
31
32  my @order = sort {
33    ($options->{$a}{order} || 9999) <=> ($options->{$b}{order} || 9999)
34    || ($config->{added_order} ? ($options->{$a}{added_order} <=> $options->{$b}{added_order}) : 0)
35    || $a cmp $b
36  } keys %$options;
37
38  for my $option (@order) {
39    my %attributes = %{ $options->{$option} };
40
41    push @{ $fullnames{ $attributes{option} } }, $option;
42  }
43
44  for my $name (keys %fullnames) {
45    if (@{ $fullnames{$name} } > 1) {
46      croak "Multiple option attributes named $name: [@{ $fullnames{$name} }]";
47    }
48  }
49
50  for my $option (@order) {
51    my %attributes = %{ $options->{$option} };
52
53    my $name = $attributes{option};
54    my $doc = $attributes{doc};
55    $doc = "no documentation for $name" unless defined $doc;
56
57    push @getopt, [] if $attributes{spacer_before};
58    push @getopt, [ _osprey_option_to_getopt($option, %attributes), $doc, ($attributes{hidden} ? { hidden => 1} : ()) ];
59    push @getopt, [] if $attributes{spacer_after};
60
61    push @{ $abbreviations{$name} }, $option;
62
63    # If we allow abbreviating long option names, an option can be called by any prefix of its name,
64    # unless that prefix is an option name itself. Ambiguous cases (an abbreviation is a prefix of
65    # multiple option names) are handled later in _osprey_fix_argv.
66    if ($config->{abbreviate}) {
67      for my $len (1 .. length($name) - 1) {
68        my $abbreviated = substr $name, 0, $len;
69        push @{ $abbreviations{$abbreviated} }, $name unless exists $fullnames{$abbreviated};
70      }
71    }
72  }
73
74  return \@getopt, \%abbreviations;
75}
76
77sub _osprey_fix_argv {
78  my ($options, $abbreviations) = @_;
79
80  my @new_argv;
81
82  while (defined( my $arg = shift @ARGV )) {
83    # As soon as we find a -- or a non-option word, stop processing and leave everything
84    # from there onwards in ARGV as either positional args or a subcommand.
85    if ($arg eq '--' or $arg eq '-' or $arg !~ /^-/) {
86      push @new_argv, $arg, @ARGV;
87      last;
88    }
89
90    my ($arg_name_with_dash, $arg_value) = split /=/, $arg, 2;
91    unshift @ARGV, $arg_value if defined $arg_value;
92
93    my ($dash, $negative, $arg_name_without_dash)
94      = $arg_name_with_dash =~ /^(-+)(no\-)?(.+)$/;
95
96    my $option_name;
97
98    if ($dash eq '--') {
99      my $option_names = $abbreviations->{$arg_name_without_dash};
100      if (defined $option_names) {
101        if (@$option_names == 1) {
102          $option_name = $option_names->[0];
103        } else {
104          # TODO: can't we produce a warning saying that it's ambiguous and which options conflict?
105          $option_name = undef;
106        }
107      }
108    }
109
110    my $arg_name = ($dash || '') . ($negative || '');
111    if (defined $option_name) {
112      $arg_name .= $option_name;
113    } else {
114      $arg_name .= $arg_name_without_dash;
115    }
116
117    push @new_argv, $arg_name;
118    if (defined $option_name && $options->{$option_name}{format}) {
119      push @new_argv, shift @ARGV;
120    }
121  }
122
123  return @new_argv;
124}
125
126use Moo::Role;
127
128requires qw(_osprey_config _osprey_options _osprey_subcommands);
129
130has 'parent_command' => (
131  is => 'ro',
132);
133
134has 'invoked_as' => (
135  is => 'ro',
136);
137
138sub new_with_options {
139  my ($class, %params) = @_;
140  my %config = $class->_osprey_config;
141
142  local @ARGV = @ARGV if $config{protect_argv};
143
144  if (!defined $params{invoked_as}) {
145    $params{invoked_as} = Getopt::Long::Descriptive::prog_name();
146  }
147
148  my ($parsed_params, $usage) = $class->parse_options(%params);
149
150  if ($parsed_params->{h}) {
151    return $class->osprey_usage(1, $usage);
152  } elsif ($parsed_params->{help}) {
153    return $class->osprey_help(1, $usage);
154  } elsif ($parsed_params->{man}) {
155    return $class->osprey_man($usage);
156  }
157
158  my %merged_params;
159  if ($config{prefer_commandline}) {
160    %merged_params = (%params, %$parsed_params);
161  } else {
162    %merged_params = (%$parsed_params, %params);
163  }
164
165  my %subcommands = $class->_osprey_subcommands;
166  my ($subcommand_name, $subcommand_class);
167  if (@ARGV && $ARGV[0] ne '--') { # Check what to do with remaining options
168    if ($ARGV[0] =~ /^--/) { # Getopt stopped at an unrecognized option, error.
169      print STDERR "Unknown option '$ARGV[0]'.\n";
170      return $class->osprey_usage(1, $usage);
171    } elsif (%subcommands) {
172      $subcommand_name = shift @ARGV; # Remove it so the subcommand sees only options
173      $subcommand_class = $subcommands{$subcommand_name};
174      if (!defined $subcommand_class) {
175        print STDERR "Unknown subcommand '$subcommand_name'.\n";
176        return $class->osprey_usage(1, $usage);
177      }
178    }
179    # If we're not expecting a subcommand, and getopt didn't stop at an option, consider the remainder
180    # as positional args and leave them in ARGV.
181  }
182
183  my $self;
184  unless (eval { $self = $class->new(%merged_params); 1 }) {
185    if ($@ =~ /^Attribute \((.*?)\) is required/) {
186      print STDERR "$1 is missing\n";
187    } elsif ($@ =~ /^Missing required arguments: (.*) at /) {
188      my @missing_required = split /,\s/, $1;
189      print STDERR "$_ is missing\n" for @missing_required;
190    } elsif ($@ =~ /^(.*?) required/) {
191      print STDERR "$1 is missing\n";
192    } elsif ($@ =~ /^isa check .*?failed: /) {
193      print STDERR substr($@, index($@, ':') + 2);
194    } else {
195      print STDERR $@;
196    }
197    return $class->osprey_usage(1, $usage);
198  }
199
200  return $self unless $subcommand_class;
201
202  use_module($subcommand_class) unless ref $subcommand_class;
203
204  return $subcommand_class->new_with_options(
205      %params,
206      parent_command => $self,
207      invoked_as => "$params{invoked_as} $subcommand_name"
208  );
209}
210
211sub parse_options {
212  my ($class, %params) = @_;
213
214  my %options = $class->_osprey_options;
215  my %config = $class->_osprey_config;
216  my %subcommands = $class->_osprey_subcommands;
217
218  my ($options, $abbreviations) = _osprey_prepare_options(\%options, \%config);
219  @ARGV = _osprey_fix_argv(\%options, $abbreviations);
220
221  my @getopt_options = %subcommands ? qw(require_order) : ();
222
223  push @getopt_options, @{$config{getopt_options}} if defined $config{getopt_options};
224
225  my $prog_name = $params{invoked_as};
226  $prog_name = Getopt::Long::Descriptive::prog_name() if !defined $prog_name;
227
228  my $usage_str = $config{usage_string};
229  unless (defined $usage_str) {
230    if (%subcommands) {
231      $usage_str = "Usage: $prog_name %o [subcommand]";
232    } else {
233      $usage_str = "Usage: $prog_name %o";
234    }
235  }
236
237  my ($opt, $usage) = describe_options(
238    $usage_str,
239    @$options,
240    [],
241    [ 'h', "show a short help message" ],
242    [ 'help', "show a long help message" ],
243    [ 'man', "show the manual" ],
244    { getopt_conf => \@getopt_options },
245  );
246
247  $usage->{prog_name} = $prog_name;
248  $usage->{target} = $class;
249
250  if ($usage->{should_die}) {
251    return $class->osprey_usage(1, $usage);
252  }
253
254  my %parsed_params;
255
256  for my $name (keys %options, qw(h help man)) {
257    my $val = $opt->$name();
258    $parsed_params{$name} = $val if defined $val;
259  }
260
261  return \%parsed_params, $usage;
262
263}
264
265sub osprey_usage {
266  my ($class, $code, @messages) = @_;
267
268  my $usage;
269
270  if (@messages && blessed($messages[0]) && $messages[0]->isa('CLI::Osprey::Descriptive::Usage')) {
271    $usage = shift @messages;
272  } else {
273    local @ARGV = ();
274    (undef, $usage) = $class->parse_options(help => 1);
275  }
276
277  my $message;
278  $message = join("\n", @messages, '') if @messages;
279  $message .= $usage . "\n";
280
281  if ($code) {
282    CORE::warn $message;
283  } else {
284    print $message;
285  }
286  exit $code if defined $code;
287  return;
288}
289
290sub osprey_help {
291  my ($class, $code, $usage) = @_;
292
293  unless (defined $usage && blessed($usage) && $usage->isa('CLI::Osprey::Descriptive::Usage')) {
294    local @ARGV = ();
295    (undef, $usage) = $class->parse_options(help => 1);
296  }
297
298  my $message = $usage->option_help . "\n";
299
300  if ($code) {
301    CORE::warn $message;
302  } else {
303    print $message;
304  }
305  exit $code if defined $code;
306  return;
307}
308
309sub osprey_man {
310  my ($class, $usage, $output) = @_;
311
312  unless (defined $usage && blessed($usage) && $usage->isa('CLI::Osprey::Descriptive::Usage')) {
313    local @ARGV = ();
314    (undef, $usage) = $class->parse_options(man => 1);
315  }
316
317  my $tmpdir = Path::Tiny->tempdir;
318  my $podfile = $tmpdir->child("help.pod");
319  $podfile->spew_utf8($usage->option_pod);
320
321  require Pod::Usage;
322  Pod::Usage::pod2usage(
323    -verbose => 2,
324    -input => "$podfile",
325    -exitval => 'NOEXIT',
326    -output => $output,
327  );
328
329  exit(0);
330}
331
332sub _osprey_subcommand_desc {
333  my ($class) = @_;
334  my %config = $class->_osprey_config;
335  return $config{desc};
336}
337
3381;
339
340__END__
341
342=pod
343
344=encoding UTF-8
345
346=head1 NAME
347
348CLI::Osprey::Role - Role for CLI::Osprey applications
349
350=head1 VERSION
351
352version 0.08
353
354=head1 AUTHOR
355
356Andrew Rodland <arodland@cpan.org>
357
358=head1 COPYRIGHT AND LICENSE
359
360This software is copyright (c) 2020 by Andrew Rodland.
361
362This is free software; you can redistribute it and/or modify it under
363the same terms as the Perl 5 programming language system itself.
364
365=cut
366