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