view release on metacpan or  search on metacpan

bin/perlbrewise-spec  view on Meta::CPAN

  sub app {
    my $self   = shift;
    my $code   = $self->{app} ||= shift;
    my $parser = $self->_option_parser;
    my (%options, @options_spec, $application_class, $app);
  
    # has to be run before calculating option spec.
    # cannot do ->can() as application_class isn't created yet.
    if ($self->_subcommand_activate($ARGV[0])) { shift @ARGV; }
    for my $option (@{$self->{options}}) {
      my $switch = $self->_attr_to_option($option->{name});
      push @options_spec, $self->_calculate_option_spec($option);
      $options{$switch} = $option->{default}     if exists $option->{default};
      $options{$switch} = [@{$options{$switch}}] if ref($options{$switch}) eq 'ARRAY';
    }
  
    unless ($parser->getoptions(\%options, @options_spec, $self->_default_options)) {
      $self->_exit(1);
    }
  
    if ($options{help}) {
      $self->print_help;
      $self->_exit('help');
    }
    elsif ($options{man}) {
      system $PERLDOC => $self->documentation;
      $self->_exit($? >> 8);
    }
    elsif ($options{version}) {
      $self->print_version;
      $self->_exit('version');
    }
  
    $application_class = $self->{application_class} ||= $self->_generate_application_class($code);
    $app = $application_class->new(
      {map { my $k = $self->_option_to_attr($_); $k => $self->_upgrade($k, $options{$_}) } keys %options});
  
    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 import {
    my ($class, %args) = @_;
    my @caller = caller;
    my $self   = $class->new({caller => \@caller});
    my $ns     = $caller[0] . '::';
    my %export;
  
    strict->import;
    warnings->import;
  
    $self->{skip_subs} = {app => 1, option => 1, version => 1, documentation => 1, extends => 1, subcommand => 1};
  
    no strict 'refs';
    for my $name (keys %$ns) {
      $self->{'skip_subs'}{$name} = 1;
    }
  
    for my $k (qw(app extends option version documentation subcommand)) {
      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{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, $args) = @_;
    my $self = bless $args, $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 ($default, %args);
  
    if (@_ % 2) {
      $default = shift;
      %args    = @_;
    }
    else {
      %args = @_;
    }
  
    if ($args{alias} and !ref $args{alias}) {
      $args{alias} = [$args{alias}];
    }
  
    push @{$self->{options}}, {default => $default, %args, type => $type, name => $name, documentation => $documentation};
  
    return $self;
  }
  
  sub options { $_[0]->{options} }