view release on metacpan or  search on metacpan

lib/Applify.pm  view on Meta::CPAN

  # Check if we should abort running the app based on user argv
  if (!$got_valid_options) {
    $self->_exit(1);
  }
  elsif ($argv{help}) {
    $self->print_help;
    $self->_exit('help');
  }
  elsif ($argv{man}) {
    system $PERLDOC => $self->documentation;
    $self->_exit($? >> 8);
  }
  elsif ($argv{version}) {
    $self->print_version;
    $self->_exit('version');
  }

  # Create the application and run (or return) it
  local $INSTANTIATING = 1;
  local $@;
  my $app = eval {
    $self->{application_class} ||= $self->_generate_application_class;
    $self->{application_class}->new(\%argv);
  } or do {
    $@ =~ s!\sat\s.*!!s unless $ENV{APPLIFY_VERBOSE};
    $self->print_help;
    local $! = 1;    # exit value
    die "\nInvalid input:\n\n$@\n";
  };

  return $app if defined wantarray;    # $app = do $script_file;
  $self->_exit($app->run(@ARGV));
}

sub documentation {
  return $_[0]->{documentation} if @_ == 1;
  $_[0]->{documentation} = $_[1] or die 'Usage: documentation $file|$module_name;';
  return $_[0];
}

sub extends {
  my $self = shift;
  $self->{extends} = [@_];
  return $self;
}

sub hook {
  my ($self, $name, $cb) = @_;
  push @{$self->{hook}{$name}}, $cb;
  return $self;
}

sub import {
  my ($class, %args) = @_;
  my @caller = caller;
  my $self   = $class->new({caller => \@caller});
  my $ns     = $caller[0] . '::';
  my %export;

  strict->import;
  warnings->import;

  no strict 'refs';
  $self->{skip_subs}{$_} = 1 for keys %$ns;

  for my $k (qw(app extends hook option version documentation subcommand)) {
    $self->{skip_subs}{$k} = 1;
    my $name = $args{$k} // $k;
    next unless $name;
    $export{$k} = $name =~ /::/ ? $name : "$caller[0]\::$name";
  }

  no warnings 'redefine';    # need to allow redefine when loading a new app
  *{$export{app}}           = sub (&) { $self->app(@_) };
  *{$export{hook}}          = sub { $self->hook(@_) };
  *{$export{option}}        = sub { $self->option(@_) };
  *{$export{version}}       = sub { $self->version(@_) };
  *{$export{documentation}} = sub { $self->documentation(@_) };
  *{$export{extends}}       = sub { $self->extends(@_) };
  *{$export{subcommand}}    = sub { $self->subcommand(@_) };
}

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

  $self->{options} ||= [];
  $self->{caller} or die 'Usage: $self->new({ caller => [...], ... })';

  return $self;
}

sub option {
  my $self          = shift;
  my $type          = shift or die 'Usage: option $type => ...';
  my $name          = shift or die 'Usage: option $type => $name => ...';
  my $documentation = shift or die 'Usage: option $type => $name => $documentation, ...';

  my %option = @_ % 2 ? (default => @_) : @_;
  $option{alias} = [$option{alias}] if $option{alias} and !ref $option{alias};
  $option{arg}   = do { local $_ = $name; s!_!-!g; $_ } unless $option{arg};
  $option{default} //= !!0 if $type eq 'bool';

  push @{$self->options}, {%option, type => $type, name => $name, documentation => $documentation};

  return $self;
}

sub option_parser {
  my $self = shift;
  return do { $self->{option_parser} = shift; $self } if @_;

  my @config = qw(no_auto_help no_auto_version pass_through);
  push @config, 'debug' if $ENV{APPLIFY_DEBUG};
  return $self->{option_parser} ||= do {
    require Getopt::Long;
    Getopt::Long::Parser->new(config => \@config);
  };
}