File Coverage

blib/lib/Getopt/App.pm

Criterion	Covered	Total	%
statement	202	210	96.1
branch	89	112	79.4
condition	33	45	73.3
subroutine	29	29	100.0
pod	10	10	100.0
total	363	406	89.4

package Getopt::App;
use feature qw(:5.16);
use strict;
use warnings;
use utf8;

use Carp         qw(croak);
use Getopt::Long ();
use List::Util   qw(first);

use constant DEBUG => $ENV{GETOPT_APP_DEBUG} || 0;

our $VERSION = '1.01';

our ($DEPTH, $OPT_COMMENT_RE, $OPTIONS, $SUBCOMMAND, $SUBCOMMANDS, %APPS) = (-1, qr{\s+\#\s+});

our $call_maybe = sub {
  my ($app, $m) = (shift, shift);
  my $pkg = !DEBUG ? '' : $app->can($m) ? $app : __PACKAGE__->can($m) ? __PACKAGE__ : 'SKIP';
  warn sprintf "[getopt::app] %s::%s()\n", $pkg, $m if DEBUG;
  $m = $app->can($m) || __PACKAGE__->can($m);
  return $m ? $app->$m(@_) : undef;
};

sub bundle {
  my ($class, $script, $OUT) = (@_, \*STDOUT);
  my ($package, @script);

  open my $SCRIPT, '<', $script or croak "Can't read $script: $!";
  while (my $line = readline $SCRIPT) {
    if ($line =~ /\bDEBUG\b/) {
      next;
    }
    elsif ($line =~ m!^\s*package\s+\S+\s*;!) {    # look for app class name
      $package .= $line;
      last;
    }
    elsif ($. == 1) {                              # look for hashbang
      $line =~ m/^#!/ ? print {$OUT} $line : do { print {$OUT} "#!$^X\n"; push @script, $line };
    }
    else {
      push @script, $line;
      last if $line =~ m!^[^#]+;!;
    }
  }

  my $out_line = '';
  open my $SELF, '<', __FILE__ or croak "Can't read Getopt::App: $!";
  while (my $line = readline $SELF) {
    next if $line =~ m!(?:\bVERSION\s|^\s*$)!;                 # TODO: Should version get skipped?
    next if $line =~ m!^sub bundle\s\{! .. $line =~ m!^}$!;    # skip bundle()
    last if $line =~ m!^1;\s*$!;                               # do not include POD

    chomp $line;
    if ($line =~ m!^sub\s!) {
      print {$OUT} $out_line, "\n" if $out_line;
      $line =~ m!\}$! ? print {$OUT} $line, "\n" : ($out_line = $line);
    }
    elsif ($line =~ m!^}$!) {
      print {$OUT} $out_line, $line, "\n";
      $out_line = '';
    }
    else {
      $line =~ s!^[ ]{2,}!!;    # remove leading white space
      $line =~ s!\#\s.*!!;      # remove comments
      $out_line .= $line;
    }
  }

  print {$OUT} qq(BEGIN{\$INC{'Getopt/App.pm'}='BUNDLED'}\n);
  print {$OUT} +($package || "package main\n");
  print {$OUT} @script;
  print {$OUT} $_ while readline $SCRIPT;
}

sub capture {
  my ($app, $argv) = @_;

  require File::Temp;
  my ($STDOUT_CAPTURE, $STDERR_CAPTURE) = (File::Temp->new, File::Temp->new);
  open my $STDOUT_ORIG, '>&STDOUT' or die "Can't remember original STDOUT: $!";
  open my $STDERR_ORIG, '>&STDERR' or die "Can't remember original STDERR: $!";

  my $restore = sub {
    open STDERR, '>&', fileno($STDERR_ORIG) or die "Can't restore STDERR: $!";
    open STDOUT, '>&', fileno($STDOUT_ORIG) or die "Can't restore STDOUT: $!";
    die $_[0] if $_[0];
  };

  open STDOUT, '>&', fileno($STDOUT_CAPTURE) or $restore->("Can't capture STDOUT: $!");
  open STDERR, '>&', fileno($STDERR_CAPTURE) or $restore->("Can't capture STDERR: $!");

  my $exit_value;
  unless (eval { $exit_value = $app->($argv || [@ARGV]); 1; }) {
    print STDERR $@;
    $exit_value = int $!;
  }

  STDERR->flush;
  STDOUT->flush;
  $restore->();
  seek $STDERR_CAPTURE, 0, 0;
  seek $STDOUT_CAPTURE, 0, 0;

  return [join('', <$STDOUT_CAPTURE>), join('', <$STDERR_CAPTURE>), $exit_value];
}

sub extract_usage {
  my %pod2usage;
  $pod2usage{'-sections'} = shift;
  $pod2usage{'-input'}    = shift || (caller)[1];
  $pod2usage{'-verbose'}  = 99 if $pod2usage{'-sections'};

  require Pod::Usage;
  open my $USAGE, '>', \my $usage;
  Pod::Usage::pod2usage(-exitval => 'noexit', -output => $USAGE, %pod2usage);
  close $USAGE;

  $usage //= '';
  $usage =~ s!^(.*?)\n!!s if $pod2usage{'-sections'};
  $usage =~ s!^Usage:\n\s+([A-Z])!$1!s;                 # Remove "Usage" header if SYNOPSIS has a description
  $usage =~ s!^    !!gm;

  return join '', $usage, _usage_for_subcommands($SUBCOMMANDS || []), _usage_for_options($OPTIONS || []);
}

sub getopt_complete_reply { Getopt::App::Complete::complete_reply(@_) }

sub getopt_configure {qw(bundling no_auto_abbrev no_ignore_case pass_through require_order)}

sub getopt_load_subcommand {
  my ($app, $subcommand, $argv) = @_;
  return $subcommand->[1] if ref $subcommand->[1] eq 'CODE';

  my $method      = $subcommand->[1] =~ /^\w+$/ && $app->can($subcommand->[1]);
  my @option_spec = @$OPTIONS;
  return sub { _run($app, [@option_spec], $_[0], $method) }
    if $method;

  ($@, $!) = ('', 0);
  croak "Unable to load subcommand $subcommand->[0]: $@ ($!)" unless my $code = do $subcommand->[1];
  return $code;
}

sub getopt_post_process_argv {
  my ($app, $argv, $state) = @_;
  return unless $state->{valid};
  return unless $argv->[0] and $argv->[0] =~ m!^-!;
  $! = 1;
  die "Invalid argument or argument order: @$argv\n";
}

sub getopt_unknown_subcommand {
  my ($app, $argv) = @_;
  $! = 2;
  die "Unknown subcommand: $argv->[0]\n";
}

sub import {
  my ($class, @flags) = @_;
  my $caller = caller;

  $_->import for qw(strict warnings utf8);
  feature->import(':5.16');

  my $skip_default;
  no strict qw(refs);
  while (my $flag = shift @flags) {
    if ($flag eq '-capture') {
      *{"$caller\::capture"} = \&capture;
      $skip_default = 1;
    }
    elsif ($flag eq '-complete') {
      require Getopt::App::Complete;
      *{"$caller\::generate_completion_script"} = \&Getopt::App::Complete::generate_completion_script;
    }
    elsif ($flag eq '-signatures') {
      require experimental;
      experimental->import(qw(signatures));
    }
    elsif ($flag !~ /^-/) {
      croak "package definition required - cannot extend main with $flag!" if $caller eq 'main';
      croak "require $flag FAIL $@" unless eval "require $flag;1";
      push @{"${caller}::ISA"}, $flag;
    }
  }

  unless ($skip_default) {
    *{"$caller\::extract_usage"} = \&extract_usage unless $caller->can('extract_usage');
    *{"$caller\::new"}           = \&new           unless $caller->can('new');
    *{"$caller\::run"}           = \&run;
  }
}

sub new {
  my $class = shift;
  bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
}

sub run {
  my ($cb, @option_spec) = (pop, @_);
  my $class = caller;
  exit _run($class->new, [@option_spec], [@ARGV], $cb) unless defined wantarray;
  return sub { _run($class->new, [@option_spec], $_[0], $cb) };
}

sub _exit {
  my ($app, $exit_value) = @_;
  $exit_value = $app->$call_maybe(getopt_post_process_exit_value => $exit_value) // $exit_value;
  $exit_value = 0   unless $exit_value and $exit_value =~ m!^\d{1,3}$!;
  $exit_value = 255 unless $exit_value < 255;
  return $exit_value;
}

sub _run {
  my ($app, $option_spec, $argv, $cb) = @_;
  $argv ||= [@ARGV];

  local $OPTIONS = [@$option_spec];
  local $DEPTH   = $DEPTH + 1;
  return $app->$call_maybe('getopt_complete_reply') if defined $ENV{COMP_POINT} and defined $ENV{COMP_LINE};

  $app->$call_maybe(getopt_pre_process_argv => $argv);
  local $SUBCOMMANDS = $app->$call_maybe('getopt_subcommands');
  my $exit_value = $SUBCOMMANDS ? _subcommand_run_maybe($app, $SUBCOMMANDS, $argv) : undef;
  return _exit($app, $exit_value) if defined $exit_value;

  s!$OPT_COMMENT_RE.*$!! for @$option_spec;

  my @configure = $app->$call_maybe('getopt_configure');
  my $prev      = Getopt::Long::Configure(@configure);
  my $valid     = Getopt::Long::GetOptionsFromArray($argv, $app, @$option_spec) ? 1 : 0;
  Getopt::Long::Configure($prev);
  $app->$call_maybe(getopt_post_process_argv => $argv, {valid => $valid});
  return _exit($app, $valid ? $app->$cb(@$argv) : 1);
}

sub _subcommand_run_maybe {
  my ($app, $subcommands, $argv) = @_;
  return undef unless $argv->[0] and $argv->[0] =~ m!^\w!;

  local $SUBCOMMAND;
  return $app->$call_maybe(getopt_unknown_subcommand => $argv)
    unless $SUBCOMMAND = first { $_->[0] eq $argv->[0] } @$subcommands;

  my $cb = $APPS{$SUBCOMMAND->[1]} ||= $app->$call_maybe(getopt_load_subcommand => $SUBCOMMAND, $argv);
  croak "$SUBCOMMAND->[0] did not return a code ref" unless ref $cb eq 'CODE';
  return $cb->([@$argv[1 .. $#$argv]]);
}

sub _usage_for_options {
  my ($option_spec) = @_;
  return '' unless @$option_spec;

  my ($len, @options) = (0);
  for (@$option_spec) {
    my @o = split $OPT_COMMENT_RE, $_, 2;
    $o[0] =~ s/(=[si][@%]?|\!|\+)$//;
    $o[0] = join ', ', map { length($_) == 1 ? "-$_" : "--$_" } sort { length($b) <=> length($a) } split /\|/, $o[0];
    $o[1] //= '';

    my $l = length $o[0];
    $len = $l if $l > $len;
    push @options, \@o;
  }

  return "Options:\n" . join('', map { sprintf "  %-${len}s  %s\n", @$_ } @options) . "\n";
}

sub _usage_for_subcommands {
  my ($subcommands) = @_;
  return '' unless @$subcommands;

  my ($len, @cmds) = (0);
  for my $s (@$subcommands) {
    my $l = length $s->[0];
    $len = $l if $l > $len;
    push @cmds, [$s->[0], $s->[2] // ''];
  }

  return "Subcommands:\n" . join('', map { sprintf "  %-${len}s  %s\n", @$_ } @cmds) . "\n";
}

1;

=encoding utf8

=head1 NAME

Getopt::App - Write and test your script with ease

=head1 SYNOPSIS

=head2 The script file

  #!/usr/bin/env perl
  package My::Script;
  use Getopt::App -complete, -signatures;

  # See "APPLICATION METHODS"
  sub getopt_post_process_argv ($app, $argv, $state) { ... }
  sub getopt_configure ($app) { ... }

  # run() must be the last statement in the script
  run(

    # Specify your Getopt::Long options and optionally a help text
    'h|help            # Output help',
    'v+                # Verbose output',
    'name=s            # Specify a name',
    'completion-script # Print autocomplete script',

    # Here is the main sub that will run the script
    sub ($app, @extra) {
      return print generate_completion_script() if $app->{'completion-script'};
      return print extract_usage()              if $app->{h};
      say $app->{name} // 'no name';            # Access command line options
      return 42;                                # Reture value is used as exit code
    }
  );

=head2 Running the script

The example script above can be run like any other script:

  $ my-script --name superwoman; # prints "superwoman"
  $ echo $? # 42

=head2 Testing

  use Test::More;
  use Cwd qw(abs_path);
  use Getopt::App -capture;

  # Sourcing the script returns a callback
  my $app = do(abs_path('./bin/myapp'));

  # The callback can be called with any @ARGV
  subtest name => sub {
    my $got = capture($app, [qw(--name superwoman)]);
    is $got->[0], "superwoman\n", 'stdout';
    is $got->[1], '', 'stderr';
    is $got->[2], 42, 'exit value';
  };

  done_testing;

=head2 Subcommands

  #!/usr/bin/env perl
  # Define a package to avoid mixing methods after loading the subcommand script
  package My::App::main;
  use Getopt::App -complete;

  # getopt_subcommands() is called by Getopt::App
  sub getopt_subcommands {
    my $app = shift;

    return [
      ['find',   '/path/to/subcommand/find.pl',   'Find things'],
      ['update', '/path/to/subcommand/update.pl', 'Update things'],
    ];
  }

  # run() is only called if there are no matching sub commands
  run(
    'h                 # Print help',
    'completion-script # Print autocomplete script',
    sub {
      my ($app, @args) = @_;
      return print generate_completion_script() if $app->{'completion-script'};
      return print extract_usage();
    }
  );

See L and L
for more details.

=head1 DESCRIPTION

L is a module that helps you structure your scripts and integrates
L with a very simple API. In addition it makes it very easy to
test your script, since the script file can be sourced without actually being
run.

L also supports infinite nested L
and a method for L this module with your script to prevent
depending on a module from CPAN.

=head1 VARIABLES

=head2 DEPTH

C<$Getopt::App::DEPTH> will be increased for each sub command and will be C<0>
for the first L.

=head2 SUBCOMMAND

C<$Getopt::App::SUBCOMMAND> will be set to the active sub command element. See
also L.

=head1 APPLICATION METHODS

These methods are optional, but can be defined in your script to override the
default behavior.

Order of how the methods are called:

  run(@option_spec, $cb)
    -> getopt_pre_process_argv(\@argv)
    -> getopt_configure()
    -> getopt_post_process_argv(\@argv, \%state)
    -> $cb

  run(@option_spec, $cb)
    -> getopt_pre_process_argv(\@argv)
    -> getopt_subcommands()
      -> getopt_load_subcommand($subcommand, \@argv)
        -> getopt_configure()
        -> getopt_post_process_argv(\@argv, \%state)
        -> $cb

=head2 getopt_complete_reply

  $app->getopt_complete_reply;

This method will be called instead of the L callback when the
C and C environment variables are set. The default
implementation will call L.

See also "Completion" under L.

=head2 getopt_configure

  @configure = $app->getopt_configure;

This method can be defined if you want L to be set up
differently. The default return value is:

  qw(bundling no_auto_abbrev no_ignore_case pass_through require_order)

Note that the default "pass_through" item is to enable the default
L to croak on invalid arguments, since
L will by default just warn to STDERR about unknown arguments.

=head2 getopt_load_subcommand

  $code = $app->getopt_load_subcommand($subcommand, [@ARGV]);

Takes the subcommand found in the L list and the command
line arguments and must return a CODE block. The default implementation is
simply:

    $code = do($subcommand->[1]);

=head2 getopt_post_process_argv

  $bool = $app->getopt_post_process_argv([@ARGV], {%state});

This method can be used to post process the options. C<%state> contains a key
"valid" which is true or false, depending on the return value from
L.

This method can C and optionally set C<$!> to avoid calling the function
passed to L.

The default behavior is to check if the first item in C<$argv> starts with a
hyphen, and C with an error message if so:

  Invalid argument or argument order: @$argv\n

=head2 getopt_post_process_exit_value

  $exit_value = $app->getopt_post_process_exit_value($exit_value);

A method to be called after the L function has been called.
C<$exit_value> holds the return value from L which could be any value,
not just 0-255. This value can then be changed to change the exit value from
the program.

  sub getopt_post_process_exit_value ($app, $exit_value) {
    return int(1 + rand 10);
  }

=head2 getopt_pre_process_argv

  $app->getopt_pre_process_argv($argv);

This method can be defined to pre-process C<$argv> before it is passed on to
L. Example:

  sub getopt_pre_process_argv ($app, $argv) {
    $app->{first_non_option} = shift @$argv if @$argv and $argv->[0] =~ m!^[a-z]!;
  }

This method can C and optionally set C<$!> to avoid calling the actual
L function.

=head2 getopt_subcommands

  $subcommands = $app->getopt_subcommands;

This method must be defined in the script to enable sub commands. The return
value must be either C to disable subcommands or an array-ref of
array-refs like this:

  [["subname", "/abs/path/to/sub-command-script", "help text"], ...]

The first element in each array-ref "subname" will be matched against the first
command line option, and when matched, the given subcommand item will be passed
on to L which must return a code-ref, preferably from
L. The sub command will have C<$Getopt::App::SUBCOMMAND> set to the item
found in the list.

=head2 getopt_unknown_subcommand

  $exit_value = $app->getopt_unknown_subcommand($argv);

Will be called when L is defined but C<$argv> does not
match an item in the list. Default behavior is to C with an error message:

  Unknown subcommand: $argv->[0]\n

Returning C instead of dying or a number (0-255) will cause the L
callback to be called.

=head1 EXPORTED FUNCTIONS

=head2 capture

  use Getopt::App -capture;
  my $app = do '/path/to/bin/myapp';
  my $array_ref = capture($app, [@ARGV]); # [$stdout, $stderr, $exit_value]

Used to run an C<$app> and capture STDOUT, STDERR and the exit value in that
order in C<$array_ref>. This function will also capture C. C<$@> will be
set and captured in the second C<$array_ref> element, and C<$exit_value> will
be set to C<$!>.

This function is a very slimmed down alternative to L.
The main reason why L exists in this package is that if something
inside the C<$app> throws an exception, then it will be part of the captured
C<$stderr> instead of making C throw an exception.

L is however more robust than this function, so please
try L out in case you find an edge case.

=head2 extract_usage

  # Default to "SYNOPSIS" from current file
  my $str = extract_usage($section, $file);
  my $str = extract_usage($section);
  my $str = extract_usage();

Will extract a C<$section> from POD C<$file> and append command line option
descriptions when called from inside of L. Command line options can
optionally have a description with "spaces-hash-spaces-description", like this:

  run(
    'o|option  # Some description',
    'v|verbose # Enable verbose output',
    sub {
      ...
    },
  );

This function will I be exported if a function with the same name already
exists in the script.

=head2 new

  my $app = new($class, %args);
  my $app = new($class, \%args);

This function is exported into the caller package so we can construct a new
object:

  my $app = Application::Class->new(\%args);

This function will I be exported if a function with the same name already
exists in the script.

=head2 run

  # Run a code block on valid @ARGV
  run(@option_spec, sub ($app, @extra) { ... });

  # For testing
  my $cb = run(@option_spec, sub ($app, @extra) { ... });
  my $exit_value = $cb->([@ARGV]);

L can be used to call a callback when valid command line options are
provided. On invalid arguments, warnings will be issued and the program will
exit with C<$?> set to 1.

C<$app> inside the callback is a hash blessed to the caller package. The keys
in the hash are the parsed command line options, while C<@extra> is the extra
unparsed command line options.

C<@option_spec> are the same options as L can take. Example:

  # app.pl -vv --name superwoman -o OptX cool beans
  run(qw(h|help v+ name=s o=s@), sub ($app, @extra) {
    die "No help here" if $app->{h};
    warn $app->{v};    # 2
    warn $app->{name}; # "superwoman"
    warn @{$app->{o}}; # "OptX"
    warn @extra;       # "cool beans"
    return 0;          # Used as exit code
  });

In the example above, C<@extra> gets populated, since there is a non-flag value
"cool" after a list of valid command line options.

=head1 METHODS

=head2 bundle

  Getopt::App->bundle($path_to_script);
  Getopt::App->bundle($path_to_script, $fh);

This method can be used to combine L and C<$path_to_script> into a
a single script that does not need to have L installed from CPAN.
This is for example useful for sysadmin scripts that otherwise only depends on
core Perl modules.

The script will be printed to C<$fh>, which defaults to C.

Example usage:

  perl -MGetopt::App -e'Getopt::App->bundle(shift)' ./src/my-script.pl > ./bin/my-script;

=head2 import

  use Getopt::App;
  use Getopt::App 'My::Script::Base', -signatures;
  use Getopt::App -capture;

=over 2

=item * Default

  use Getopt::App;

Passing in no flags will export the default functions L,
L and L. In addition it will save you from a lot of typing, since
it will also import the following:

  use strict;
  use warnings;
  use utf8;
  use feature ':5.16';

=item * Completion

  use Getopt::App -complete;

Same as L, but will also load L and import
L.

=item * Signatures

  use Getopt::App -signatures;

Same as L, but will also import L. This
requires Perl 5.20+.

=item * Class name

  package My::Script::Foo;
  use Getopt::App 'My::Script';

Same as L but will also make C inherit from
L. Note that a package definition is required.

=item * Capture

  use Getopt::App -capture;

This will only export L.

=back

=head1 COPYRIGHT AND LICENSE

This library is free software. You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Jan Henning Thorsen - C

=cut