lib/Catalyst/ScriptRole.pm

   1 package Catalyst::ScriptRole;
   2 use Moose::Role;
   3 use MooseX::Types::Moose qw/Str Bool/;
   4 use Pod::Usage;
   5 use namespace::autoclean;
   6
   7 with 'MooseX::Getopt';
   8
   9 has application_name => (
  10     traits => ['NoGetopt'],
  11     isa => Str,
  12     is => 'ro',
  13     required => 1,
  14 );
  15
  16 has help => (
  17     traits => ['Getopt'],
  18     cmd_aliases => 'h',
  19     isa => Bool,
  20     is => 'ro',
  21     documentation => q{Display this help and exit},
  22 );
  23
  24 sub _exit_with_usage {
  25     my $self = shift;
  26     pod2usage();
  27     exit 0;
  28 }
  29
  30 before run => sub {
  31     my $self = shift;
  32     $self->_exit_with_usage if $self->help;
  33 };
  34
  35 sub run {
  36     my $self = shift;
  37     $self->_run_application;
  38 }
  39
  40 sub _application_args {
  41     ()
  42 }
  43
  44 sub _run_application {
  45     my $self = shift;
  46     my $app = $self->application_name;
  47     Class::MOP::load_class($app);
  48     $app->run($self->_application_args);
  49 }
  50
  51 # GROSS HACK, temporary until MX::Getopt gets some proper refactoring and unfucking..
  52 around '_parse_argv' => sub {
  53     my ($orig, $self, @args) = @_;
  54     my %data = eval { $self->$orig(@args) };
  55     $self->_exit_with_usage($@) if $@;
  56     $data{usage} = Catalyst::ScriptRole::Useage->new(code => sub { shift; $self->_exit_with_usage(@_) });
  57     return %data;
  58 };
  59
  60 # This package is going away.
  61 package # Hide from PAUSE
  62     Catalyst::ScriptRole::Useage;
  63 use Moose;
  64 use namespace::autoclean;
  65
  66 has code => ( is => 'ro', required => 1 );
  67
  68 sub die { shift->code->(@_) }
  69
  70 1;
  71
  72 =head1 NAME
  73
  74 Catalyst::ScriptRole - Common functionality for Catalyst scripts.
  75
  76 =head1 SYNOPSIS
  77
  78     FIXME
  79
  80 =head1 DESCRIPTION
  81
  82     FIXME
  83
  84 =head1 AUTHORS
  85
  86 Catalyst Contributors, see Catalyst.pm
  87
  88 =head1 COPYRIGHT
  89
  90 This library is free software, you can redistribute it and/or modify
  91 it under the same terms as Perl itself.
  92
  93 =cut
  94