view release on metacpan or  search on metacpan

lib/Getopt/App.pm  view on Meta::CPAN

    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;