From: Tomas Doran Date: Thu, 26 Nov 2009 22:46:26 +0000 (+0000) Subject: Merge 'trunk' into 'better_scripts' X-Git-Tag: 5.80014_02~23 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=4cb211411c158181d7506fd45d94017bd81c7b73;hp=ab95b8e30f63584e5854e4240da1f4bc29a5f803 Merge 'trunk' into 'better_scripts' r12057@t0mlaptop (orig r12022): t0m | 2009-11-26 01:21:22 +0000 Back out 11979 until I work out why IPC::Run is getting hold of the FCGI file handle r12070@t0mlaptop (orig r12035): t0m | 2009-11-26 21:29:32 +0000 Fix test on bleadperl RT#52100 --- diff --git a/Makefile.PL b/Makefile.PL index d851efd..ccb2a19 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -18,6 +18,7 @@ all_from 'lib/Catalyst/Runtime.pm'; requires 'List::MoreUtils'; requires 'namespace::autoclean' => '0.09'; requires 'namespace::clean'; +requires 'namespace::autoclean'; requires 'B::Hooks::EndOfScope' => '0.08'; requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00903'; requires 'Class::MOP' => '0.83'; @@ -47,10 +48,10 @@ requires 'URI' => '1.35'; requires 'Task::Weaken'; requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness requires 'MRO::Compat'; +requires 'MooseX::Getopt' => '0.25'; +requires 'MooseX::Types'; requires 'String::RewritePrefix' => '0.004'; # Catalyst::Utils::resolve_namespace -recommends 'B::Hooks::OP::Check::StashChange'; - test_requires 'Class::Data::Inheritable'; test_requires 'Test::Exception'; test_requires 'Test::More' => '0.88'; diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index ef3d082..296cf43 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -2892,6 +2892,8 @@ David Naughton, C David E. Wheeler +dhoss: Devin Austin + dkubb: Dan Kubb Drew Taylor diff --git a/lib/Catalyst/ROADMAP.pod b/lib/Catalyst/ROADMAP.pod index e872e5e..9c29d1d 100644 --- a/lib/Catalyst/ROADMAP.pod +++ b/lib/Catalyst/ROADMAP.pod @@ -8,11 +8,6 @@ in the the catalyst trunk, currently at Make sure you get it from there to ensure you have the latest version. -=head2 5.80000 1st Quarter 2009 - -Next major planned release, ports Catalyst to Moose, and does some refactoring -to help app/ctx. - =head2 5.81000 =over diff --git a/lib/Catalyst/Script/CGI.pm b/lib/Catalyst/Script/CGI.pm new file mode 100644 index 0000000..e80a5f7 --- /dev/null +++ b/lib/Catalyst/Script/CGI.pm @@ -0,0 +1,34 @@ +package Catalyst::Script::CGI; +use Moose; +BEGIN { $ENV{CATALYST_ENGINE} ||= 'CGI' } +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +__PACKAGE__->meta->make_immutable; + +=head1 NAME + +Catalyst::Script::CGI - The CGI Catalyst Script + +=head1 SYNOPSIS + + myapp_cgi.pl [options] + + Options: + -h --help display this help and exits + +=head1 DESCRIPTION + +This is a script to run the Catalyst engine specialized for the CGI environment. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Catalyst/Script/Create.pm b/lib/Catalyst/Script/Create.pm new file mode 100644 index 0000000..e65a597 --- /dev/null +++ b/lib/Catalyst/Script/Create.pm @@ -0,0 +1,97 @@ +package Catalyst::Script::Create; +use Moose; +use MooseX::Types::Moose qw/Bool/; +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +has force => ( + traits => [qw(Getopt)], + cmd_aliases => 'nonew', + isa => Bool, + is => 'ro', + documentation => 'Force new scripts', +); + +has debug => ( + traits => [qw(Getopt)], + cmd_aliases => 'd', + isa => Bool, + is => 'ro', + documentation => 'Force debug mode', +); + +has mechanize => ( + traits => [qw(Getopt)], + cmd_aliases => 'mech', + isa => Bool, + is => 'ro', + documentation => 'use WWW::Mechanize', +); + +has helper_class => ( isa => 'Str', is => 'ro', default => 'Catalyst::Helper' ); + +sub run { + my ($self) = @_; + + $self->_exit_with_usage if !$self->ARGV->[0]; + + my $helper_class = $self->helper_class; + Class::MOP::load_class($helper_class); + my $helper = $helper_class->new( { '.newfiles' => !$self->force, mech => $self->mechanize } ); + + $self->_exit_with_usage unless $helper->mk_component( $self->application_name, @ARGV ); + +} + +__PACKAGE__->meta->make_immutable; + +=head1 NAME + +Catalyst::Script::Create - Create a new Catalyst Component + +=head1 SYNOPSIS + + myapp_create.pl [options] model|view|controller name [helper] [options] + + Options: + -force don't create a .new file where a file to be created exists + -mechanize use Test::WWW::Mechanize::Catalyst for tests if available + -help display this help and exits + + Examples: + myapp_create.pl controller My::Controller + myapp_create.pl controller My::Controller BindLex + myapp_create.pl -mechanize controller My::Controller + myapp_create.pl view My::View + myapp_create.pl view MyView TT + myapp_create.pl view TT TT + myapp_create.pl model My::Model + myapp_create.pl model SomeDB DBIC::Schema MyApp::Schema create=dynamic\ + dbi:SQLite:/tmp/my.db + myapp_create.pl model AnotherDB DBIC::Schema MyApp::Schema create=static\ + dbi:Pg:dbname=foo root 4321 + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + +=head1 DESCRIPTION + +Create a new Catalyst Component. + +Existing component files are not overwritten. If any of the component files +to be created already exist the file will be written with a '.new' suffix. +This behavior can be suppressed with the C<-force> option. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Catalyst/Script/FastCGI.pm b/lib/Catalyst/Script/FastCGI.pm new file mode 100644 index 0000000..11bc735 --- /dev/null +++ b/lib/Catalyst/Script/FastCGI.pm @@ -0,0 +1,121 @@ +package Catalyst::Script::FastCGI; + +BEGIN { $ENV{CATALYST_ENGINE} ||= 'FastCGI' } +use Moose; +use MooseX::Types::Moose qw/Str Bool Int/; +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +has listen => ( + traits => [qw(Getopt)], + cmd_aliases => 'l', + isa => Str, + is => 'ro', + documentation => 'Specify a listening port/socket', +); + +has pidfile => ( + traits => [qw(Getopt)], + cmd_aliases => 'pid', + isa => Str, + is => 'ro', + documentation => 'Specify a pidfile', +); + +has daemon => ( + traits => [qw(Getopt)], + isa => Bool, + is => 'ro', + cmd_aliases => 'd', + documentation => 'Daemonize (go into the background)', +); + +has manager => ( + traits => [qw(Getopt)], + isa => Str, + is => 'ro', + cmd_aliases => 'M', + documentation => 'Use a different FastCGI process manager class', +); + +has keeperr => ( + traits => [qw(Getopt)], + cmd_aliases => 'e', + isa => Bool, + is => 'ro', + documentation => 'Log STDERR', +); + +has nproc => ( + traits => [qw(Getopt)], + cmd_aliases => 'n', + isa => Int, + is => 'ro', + documentation => 'Specify a number of child processes', +); + +has detach => ( + traits => [qw(Getopt)], + cmd_aliases => 'det', + isa => Bool, + is => 'ro', + documentation => 'Detach this FastCGI process', +); + +sub _application_args { + my ($self) = shift; + return ( + $self->listen, + { + nproc => $self->nproc, + pidfile => $self->pidfile, + manager => $self->manager, + detach => $self->detach, + keep_stderr => $self->keeperr, + } + ); +} + +__PACKAGE__->meta->make_immutable; + +=head1 NAME + +Catalyst::Script::FastCGI - The FastCGI Catalyst Script + +=head1 SYNOPSIS + + myapp_fastcgi.pl [options] + + Options: + -? -help display this help and exits + -l -listen Socket path to listen on + (defaults to standard input) + can be HOST:PORT, :PORT or a + filesystem path + -n -nproc specify number of processes to keep + to serve requests (defaults to 1, + requires -listen) + -p -pidfile specify filename for pid file + (requires -listen) + -d -daemon daemonize (requires -listen) + -M -manager specify alternate process manager + (FCGI::ProcManager sub-class) + or empty string to disable + -e -keeperr send error messages to STDOUT, not + to the webserver + +=head1 DESCRIPTION + +Run a Catalyst application as fastcgi. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Catalyst/Script/Server.pm b/lib/Catalyst/Script/Server.pm new file mode 100644 index 0000000..68e6b85 --- /dev/null +++ b/lib/Catalyst/Script/Server.pm @@ -0,0 +1,246 @@ +package Catalyst::Script::Server; + +BEGIN { + $ENV{CATALYST_ENGINE} ||= 'HTTP'; + require Catalyst::Engine::HTTP; +} + +use Moose; +use MooseX::Types::Moose qw/ArrayRef Str Bool Int/; +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +__PACKAGE__->meta->get_attribute('help')->cmd_aliases('?'); + +has debug => ( + traits => [qw(Getopt)], + cmd_aliases => 'd', + isa => Bool, + is => 'ro', + documentation => q{Force debug mode}, +); + +has host => ( + traits => [qw(Getopt)], + cmd_aliases => 'h', + isa => Str, + is => 'ro', + default => 'localhost', + documentation => 'Specify an IP on this host for the server to bind to', +); + +has fork => ( + traits => [qw(Getopt)], + cmd_aliases => 'f', + isa => Bool, + is => 'ro', + default => 0, + documentation => 'Fork the server to be able to serve multiple requests at once', +); + +has port => ( + traits => [qw(Getopt)], + cmd_aliases => 'p', + isa => Int, + is => 'ro', + default => 3000, + documentation => 'Specify a different listening port (to the default port 3000)', +); + +has pidfile => ( + traits => [qw(Getopt)], + cmd_aliases => 'pid', + isa => Str, + is => 'ro', + documentation => 'Specify a pidfile', +); + +has keepalive => ( + traits => [qw(Getopt)], + cmd_aliases => 'k', + isa => Bool, + is => 'ro', + default => 0, + documentation => 'Support keepalive', +); + +has background => ( + traits => [qw(Getopt)], + cmd_aliases => 'bg', + isa => Bool, + is => 'ro', + default => 0, + documentation => 'Run in the background', +); + +has restart => ( + traits => [qw(Getopt)], + cmd_aliases => 'r', + isa => Bool, + is => 'ro', + default => 0, + documentation => 'use Catalyst::Restarter to detect code changes and restart the application', +); + +has restart_directory => ( + traits => [qw(Getopt)], + cmd_aliases => 'rdir', + isa => ArrayRef[Str], + is => 'ro', + documentation => 'Restarter directory to watch', + predicate => '_has_restart_directory', +); + +has restart_delay => ( + traits => [qw(Getopt)], + cmd_aliases => 'rd', + isa => Int, + is => 'ro', + documentation => 'Set a restart delay', + predicate => '_has_restart_delay', +); + +has restart_regex => ( + traits => [qw(Getopt)], + cmd_aliases => 'rr', + isa => Str, + is => 'ro', + documentation => 'Restart regex', + predicate => '_has_restart_regex', +); + +has follow_symlinks => ( + traits => [qw(Getopt)], + cmd_aliases => 'sym', + isa => Bool, + is => 'ro', + default => 0, + documentation => 'Follow symbolic links', +); + +sub _restarter_args { + my $self = shift; + my %args; + $args{follow_symlinks} = $self->follow_symlinks + if $self->follow_symlinks; + $args{directories} = $self->restart_directory + if $self->_has_restart_directory; + $args{sleep_interval} = $self->restart_delay + if $self->_has_restart_delay; + if ($self->_has_restart_regex) { + my $regex = $self->restart_regex; + $args{filter} = qr/$regex/; + } + $args{start_sub} = sub { $self->_run_application }; + $args{argv} = $self->ARGV; + return %args; +} + +sub run { + my $self = shift; + + local $ENV{CATALYST_DEBUG} = 1 + if $self->debug; + + if ( $self->restart ) { + die "Cannot run in the background and also watch for changed files.\n" + if $self->background; + + # If we load this here, then in the case of a restarter, it does not + # need to be reloaded for each restart. + require Catalyst; + + # If this isn't done, then the Catalyst::Devel tests for the restarter + # fail. + $| = 1 if $ENV{HARNESS_ACTIVE}; + + require Catalyst::Restarter; + + my $subclass = Catalyst::Restarter->pick_subclass; + + + my $restarter = $subclass->new( + $self->_restarter_args() + ); + + $restarter->run_and_watch; + } + else { + $self->_run_application; + } + + +} + +sub _application_args { + my ($self) = shift; + return ( + $self->port, + $self->host, + { + map { $_ => $self->$_ } qw/ + fork + keepalive + background + pidfile + keepalive + follow_symlinks + /, + }, + ); +} + +__PACKAGE__->meta->make_immutable; + +1; + +=head1 NAME + +Catalyst::Script::Server - Catalyst test server + +=head1 SYNOPSIS + + myapp_server.pl [options] + + Options: + -d --debug force debug mode + -f --fork handle each request in a new process + (defaults to false) + --help display this help and exits + -h --host host (defaults to all) + -p --port port (defaults to 3000) + -k --keepalive enable keep-alive connections + -r --restart restart when files get modified + (defaults to false) + --rd --restartdelay delay between file checks + (ignored if you have Linux::Inotify2 installed) + --rr --restartregex regex match files that trigger + a restart when modified + (defaults to '\.yml$|\.yaml$|\.conf|\.pm$') + --rdir --restartdirectory the directory to search for + modified files, can be set mulitple times + (defaults to '[SCRIPT_DIR]/..') + --sym --follow_symlinks follow symlinks in search directories + (defaults to false. this is a no-op on Win32) + --bg --background run the process in the background + --pid --pidfile specify filename for pid file + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + +=head1 DESCRIPTION + +Run a Catalyst test server for this application. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Catalyst/Script/Test.pm b/lib/Catalyst/Script/Test.pm new file mode 100644 index 0000000..53473a4 --- /dev/null +++ b/lib/Catalyst/Script/Test.pm @@ -0,0 +1,43 @@ +package Catalyst::Script::Test; +use Moose; +use Catalyst::Test (); +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +sub run { + my $self = shift; + + Catalyst::Test->import($self->application_name); + + print request($self->ARGV->[0])->content . "\n"; +} + + +__PACKAGE__->meta->make_immutable; + +=head1 NAME + +Catalyst::Script::Test - Test Catalyst application on the command line + +=head1 SYNOPSIS + + myapp_test.pl [options] /path + + Options: + -h --help display this help and exits + +=head1 DESCRIPTION + +Script to perform a test hit against your application and display the output. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Catalyst/ScriptRole.pm b/lib/Catalyst/ScriptRole.pm new file mode 100644 index 0000000..1cd745f --- /dev/null +++ b/lib/Catalyst/ScriptRole.pm @@ -0,0 +1,113 @@ +package Catalyst::ScriptRole; +use Moose::Role; +use MooseX::Types::Moose qw/Str Bool/; +use Pod::Usage; +use MooseX::Getopt; +use namespace::autoclean; + +with 'MooseX::Getopt' => { + excludes => [qw/ + _getopt_spec_warnings + _getopt_spec_exception + _getopt_full_usage + /], +}; + +has application_name => ( + traits => ['NoGetopt'], + isa => Str, + is => 'ro', + required => 1, +); + +has help => ( + traits => ['Getopt'], + isa => Bool, + is => 'ro', + documentation => q{Display this help and exit}, + cmd_aliases => ['?', 'h'], +); + +sub _getopt_spec_exception {} + +sub _getopt_spec_warnings { + shift; + warn @_; +} + +sub _getopt_full_usage { + my $self = shift; + pod2usage(); + exit 0; +} + +before run => sub { + my $self = shift; + $self->_getopt_full_usage if $self->help; +}; + +sub run { + my $self = shift; + $self->_run_application; +} + +sub _application_args { + () +} + +sub _run_application { + my $self = shift; + my $app = $self->application_name; + Class::MOP::load_class($app); + $app->run($self->_application_args); +} + +1; + +=head1 NAME + +Catalyst::ScriptRole - Common functionality for Catalyst scripts. + +=head1 SYNOPSIS + + package MyApp::Script::Foo; + use Moose; + use namespace::autoclean; + + with 'Catalyst::ScriptRole'; + + sub _application_args { ... } + +=head1 DESCRIPTION + +Role with the common functionality of Catalyst scripts. + +=head1 METHODS + +=head2 run + +The method invoked to run the application. + +=head1 ATTRIBUTES + +=head2 application_name + +The name of the application class, e.g. MyApp + +=head1 SEE ALSO + +L + +L + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Catalyst/ScriptRunner.pm b/lib/Catalyst/ScriptRunner.pm new file mode 100644 index 0000000..247ce30 --- /dev/null +++ b/lib/Catalyst/ScriptRunner.pm @@ -0,0 +1,56 @@ +package Catalyst::ScriptRunner; +use Moose; +use FindBin; +use lib; +use File::Spec; +use namespace::autoclean; + +sub run { + my ($self, $class, $scriptclass) = @_; + my $classtoload = "${class}::Script::$scriptclass"; + + lib->import(File::Spec->catdir($FindBin::Bin, '..', 'lib')); + + unless ( eval { Class::MOP::load_class($classtoload) } ) { + warn("Could not load $classtoload - falling back to Catalyst::Script::$scriptclass : $@\n") + if $@ !~ /Can't locate/; + $classtoload = "Catalyst::Script::$scriptclass"; + Class::MOP::load_class($classtoload); + } + $classtoload->new_with_options( application_name => $class )->run; +} + +__PACKAGE__->meta->make_immutable; + +=head1 NAME + +Catalyst::ScriptRunner - The Catalyst Framework script runner + +=head1 SYNOPSIS + + # Will run MyApp::Script::Server if it exists, otherwise + # will run Catalyst::Script::Server. + Catalyst::ScriptRunner->run('MyApp', 'Server'); + +=head1 DESCRIPTION + +This class is responsible for running scripts, either in the application specific namespace +(e.g. C), or the Catalyst namespace (e.g. C) + +=head1 METHODS + +=head2 run ($application_class, $scriptclass) + +Called with two parameters, the application classs (e.g. MyApp) +and the script class, (i.e. one of Server/FastCGI/CGI/Create/Test) + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/t/aggregate/unit_core_script_cgi.t b/t/aggregate/unit_core_script_cgi.t new file mode 100644 index 0000000..ba187e1 --- /dev/null +++ b/t/aggregate/unit_core_script_cgi.t @@ -0,0 +1,20 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +use FindBin qw/$Bin/; +use lib "$Bin/../lib"; + +use Test::More; +use Test::Exception; + +use Catalyst::Script::CGI; + +local @ARGV; +lives_ok { + Catalyst::Script::CGI->new_with_options(application_name => 'TestAppToTestScripts')->run; +} "new_with_options"; +shift @TestAppToTestScripts::RUN_ARGS; +is_deeply \@TestAppToTestScripts::RUN_ARGS, [], "no args"; + +done_testing; diff --git a/t/aggregate/unit_core_script_create.t b/t/aggregate/unit_core_script_create.t new file mode 100644 index 0000000..db2e5af --- /dev/null +++ b/t/aggregate/unit_core_script_create.t @@ -0,0 +1,75 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Exception; + +use FindBin qw/$Bin/; +use lib "$Bin/../lib"; + +{ + package TestCreateScript; + use Moose; + extends 'Catalyst::Script::Create'; + our $help; + sub _exit_with_usage { $help++ } +} + +{ + package TestHelperClass; + use Moose; + + has 'newfiles' => ( is => 'ro', init_arg => '.newfiles' ); + has 'mech' => ( is => 'ro' ); + our @ARGS; + our %p; + sub mk_component { + my $self = shift; + @ARGS = @_; + %p = ( '.newfiles' => $self->newfiles, mech => $self->mech); + return $self->_mk_component_return; + } + sub _mk_component_return { 1 } +} +{ + package TestHelperClass::False; + use Moose; + extends 'TestHelperClass'; + sub _mk_component_return { 0 } +} + +{ + local $TestCreateScript::help; + local @ARGV; + lives_ok { + TestCreateScript->new_with_options(application_name => 'TestAppToTestScripts', helper_class => 'TestHelperClass')->run; + } "no argv"; + ok $TestCreateScript::help, 'Exited with usage info'; +} +{ + local $TestCreateScript::help; + local @ARGV = 'foo'; + local @TestHelperClass::ARGS; + local %TestHelperClass::p; + lives_ok { + TestCreateScript->new_with_options(application_name => 'TestAppToTestScripts', helper_class => 'TestHelperClass')->run; + } "with argv"; + ok !$TestCreateScript::help, 'Did not exit with usage into'; + is_deeply \@TestHelperClass::ARGS, ['TestAppToTestScripts', 'foo'], 'Args correct'; + is_deeply \%TestHelperClass::p, { '.newfiles' => 1, mech => undef }, 'Params correct'; +} + +{ + local $TestCreateScript::help; + local @ARGV = 'foo'; + local @TestHelperClass::ARGS; + local %TestHelperClass::p; + lives_ok { + TestCreateScript->new_with_options(application_name => 'TestAppToTestScripts', helper_class => 'TestHelperClass::False')->run; + } "with argv"; + ok $TestCreateScript::help, 'Did exit with usage into as mk_component returned false'; + is_deeply \@TestHelperClass::ARGS, ['TestAppToTestScripts', 'foo'], 'Args correct'; + is_deeply \%TestHelperClass::p, { '.newfiles' => 1, mech => undef }, 'Params correct'; +} + +done_testing; diff --git a/t/aggregate/unit_core_script_fastcgi.t b/t/aggregate/unit_core_script_fastcgi.t new file mode 100644 index 0000000..7d4da0f --- /dev/null +++ b/t/aggregate/unit_core_script_fastcgi.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use FindBin qw/$Bin/; +use lib "$Bin/../lib"; + +use Test::More; +use Test::Exception; + +use Catalyst::Script::FastCGI; + +my $testopts; + +# Test default (no opts/args behaviour) +testOption( [ qw// ], [undef, opthash()] ); + +# listen socket +testOption( [ qw|-l /tmp/foo| ], ['/tmp/foo', opthash()] ); +testOption( [ qw/-l 127.0.0.1:3000/ ], ['127.0.0.1:3000', opthash()] ); + +#daemonize -d --daemon +testOption( [ qw/-d/ ], [undef, opthash()] ); +testOption( [ qw/--daemon/ ], [undef, opthash()] ); + +# pidfile -pidfile --pid --pidfile +testOption( [ qw/--pidfile cat.pid/ ], [undef, opthash(pidfile => 'cat.pid')] ); +testOption( [ qw/--pid cat.pid/ ], [undef, opthash(pidfile => 'cat.pid')] ); + +# manager +testOption( [ qw/--manager foo::bar/ ], [undef, opthash(manager => 'foo::bar')] ); +testOption( [ qw/-M foo::bar/ ], [undef, opthash(manager => 'foo::bar')] ); + +# keeperr +testOption( [ qw/--keeperr/ ], [undef, opthash(keep_stderr => 1)] ); +testOption( [ qw/-e/ ], [undef, opthash(keep_stderr => 1)] ); + +# nproc +testOption( [ qw/--nproc 6/ ], [undef, opthash(nproc => 6)] ); +testOption( [ qw/--n 6/ ], [undef, opthash(nproc => 6)] ); + +# detach +testOption( [ qw/--detach/ ], [undef, opthash(detach => 1)] ); +testOption( [ qw/--det/ ], [undef, opthash(detach => 1)] ); + +done_testing; + +sub testOption { + my ($argstring, $resultarray) = @_; + + local @ARGV = @$argstring; + local @TestAppToTestScripts::RUN_ARGS; + lives_ok { + Catalyst::Script::FastCGI->new_with_options(application_name => 'TestAppToTestScripts')->run; + } "new_with_options"; + # First element of RUN_ARGS will be the script name, which we don't care about + shift @TestAppToTestScripts::RUN_ARGS; + is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison"; +} + +# Returns the hash expected when no flags are passed +sub opthash { + return { + pidfile => undef, + keep_stderr => undef, + detach => undef, + nproc => undef, + manager => undef, + @_, + }; +} diff --git a/t/aggregate/unit_core_script_help.t b/t/aggregate/unit_core_script_help.t new file mode 100644 index 0000000..0287990 --- /dev/null +++ b/t/aggregate/unit_core_script_help.t @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Exception; + +use FindBin qw/$Bin/; +use lib "$Bin/../lib"; + +{ + package TestHelpScript; + use Moose; + with 'Catalyst::ScriptRole'; + our $help; + sub _getopt_full_usage { $help++ } +} + +test('-h'); +test('--help'); +test('-?'); + +sub test { + local $TestHelpScript::help; + local @ARGV = (@_); + lives_ok { + TestHelpScript->new_with_options(application_name => 'TestAppToTestScripts')->run; + } 'Lives'; + ok $TestHelpScript::help, 'Got help'; +} + +done_testing; diff --git a/t/aggregate/unit_core_script_server.t b/t/aggregate/unit_core_script_server.t new file mode 100644 index 0000000..035be38 --- /dev/null +++ b/t/aggregate/unit_core_script_server.t @@ -0,0 +1,115 @@ +use strict; +use warnings; + +use FindBin qw/$Bin/; +use lib "$Bin/../lib"; + +use Test::More; +use Test::Exception; + +use Catalyst::Script::Server; + +my $testopts; + +# Test default (no opts/args behaviour) +testOption( [ qw// ], ['3000', 'localhost', opthash()] ); + +# Old version supports long format opts with either one or two dashes. New version only supports two. +# Old New +# help -? -help --help -? --help +# debug -d -debug --debug -d --debug +# host -host --host --host +testOption( [ qw/--host testhost/ ], ['3000', 'testhost', opthash()] ); +testOption( [ qw/-h testhost/ ], ['3000', 'testhost', opthash()] ); + +# port -p -port --port -l --listen +testOption( [ qw/-p 3001/ ], ['3001', 'localhost', opthash()] ); +testOption( [ qw/--port 3001/ ], ['3001', 'localhost', opthash()] ); + +# fork -f -fork --fork -f --fork +testOption( [ qw/--fork/ ], ['3000', 'localhost', opthash(fork => 1)] ); +testOption( [ qw/-f/ ], ['3000', 'localhost', opthash(fork => 1)] ); + +# pidfile -pidfile --pid --pidfile +testOption( [ qw/--pidfile cat.pid/ ], ['3000', 'localhost', opthash(pidfile => "cat.pid")] ); +testOption( [ qw/--pid cat.pid/ ], ['3000', 'localhost', opthash(pidfile => "cat.pid")] ); + +# keepalive -k -keepalive --keepalive -k --keepalive +testOption( [ qw/-k/ ], ['3000', 'localhost', opthash(keepalive => 1)] ); +testOption( [ qw/--keepalive/ ], ['3000', 'localhost', opthash(keepalive => 1)] ); + +# symlinks -follow_symlinks --sym --follow_symlinks +testOption( [ qw/--follow_symlinks/ ], ['3000', 'localhost', opthash(follow_symlinks => 1)] ); +testOption( [ qw/--sym/ ], ['3000', 'localhost', opthash(follow_symlinks => 1)] ); + +# background -background --bg --background +testOption( [ qw/--background/ ], ['3000', 'localhost', opthash(background => 1)] ); +testOption( [ qw/--bg/ ], ['3000', 'localhost', opthash(background => 1)] ); + +# restart -r -restart --restart -R --restart +testRestart( ['-r'], restartopthash() ); +# restart dly -rd -restartdelay --rd --restart_delay +testRestart( ['-r', '--rd', 30], restartopthash(sleep_interval => 30) ); +testRestart( ['-r', '--restart_delay', 30], restartopthash(sleep_interval => 30) ); + +# restart dir -restartdirectory --rdir --restart_directory +testRestart( ['-r', '--rdir', 'root'], restartopthash(directories => ['root']) ); +testRestart( ['-r', '--rdir', 'root', '--rdir', 'lib'], restartopthash(directories => ['root', 'lib']) ); +testRestart( ['-r', '--restart_directory', 'root'], restartopthash(directories => ['root']) ); + +# restart regex -rr -restartregex --rr --restart_regex +testRestart( ['-r', '--rr', 'foo'], restartopthash(filter => qr/foo/) ); +testRestart( ['-r', '--restart_regex', 'foo'], restartopthash(filter => qr/foo/) ); + +done_testing; + +sub testOption { + my ($argstring, $resultarray) = @_; + my $app = _build_testapp($argstring); + lives_ok { + $app->run; + }; + # First element of RUN_ARGS will be the script name, which we don't care about + shift @TestAppToTestScripts::RUN_ARGS; + is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison " . join(' ', @$argstring); +} + +sub testRestart { + my ($argstring, $resultarray) = @_; + my $app = _build_testapp($argstring); + my $args = {$app->_restarter_args}; + is_deeply delete $args->{argv}, $argstring, 'argv is arg string'; + is ref(delete $args->{start_sub}), 'CODE', 'Closure to start app present'; + is_deeply $args, $resultarray, "is_deeply comparison of restarter args " . join(' ', @$argstring); +} + +sub _build_testapp { + my ($argstring, $resultarray) = @_; + + local @ARGV = @$argstring; + local @TestAppToTestScripts::RUN_ARGS; + my $i; + lives_ok { + $i = Catalyst::Script::Server->new_with_options(application_name => 'TestAppToTestScripts'); + } "new_with_options " . join(' ', @$argstring);; + ok $i; + return $i; +} + +# Returns the hash expected when no flags are passed +sub opthash { + return { + 'pidfile' => undef, + 'fork' => 0, + 'follow_symlinks' => 0, + 'background' => 0, + 'keepalive' => 0, + @_, + }; +} + +sub restartopthash { + return { + @_, + }; +} diff --git a/t/aggregate/unit_core_script_test.t b/t/aggregate/unit_core_script_test.t new file mode 100644 index 0000000..5f56681 --- /dev/null +++ b/t/aggregate/unit_core_script_test.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use FindBin qw/$Bin/; +use lib "$Bin/../lib"; + +use Test::More; +use Test::Exception; + +use Catalyst::Script::Test; +use File::Temp qw/tempfile/; +use IO::Handle; + +is run_test('/'), "root index\n", 'correct content printed'; +is run_test('/moose/get_attribute'), "42\n", 'Correct content printed for non root action'; + +done_testing; + +sub run_test { + my $url = shift; + + my ($fh, $fn) = tempfile(); + + binmode( $fh ); + binmode( STDOUT ); + + { + local @ARGV = ($url); + my $i; + lives_ok { + $i = Catalyst::Script::Test->new_with_options(application_name => 'TestApp'); + } "new_with_options"; + ok $i; + my $saved; + open( $saved, '<&'. STDIN->fileno ) + or croak("Can't dup stdin: $!"); + open( STDOUT, '>&='. $fh->fileno ) + or croak("Can't open stdout: $!"); + eval { $i->run }; + ok !$@, 'Ran ok'; + + STDOUT->flush + or croak("Can't flush stdout: $!"); + + open( STDOUT, '>&'. fileno($saved) ) + or croak("Can't restore stdout: $!"); + } + + my $data = do { my $fh; open($fh, '<', $fn) or die $!; local $/; <$fh>; }; + $fh = undef; + unlink $fn if -r $fn; + + return $data; +} diff --git a/t/aggregate/unit_core_scriptrunner.t b/t/aggregate/unit_core_scriptrunner.t new file mode 100644 index 0000000..d9af3bc --- /dev/null +++ b/t/aggregate/unit_core_scriptrunner.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use Test::More; +use FindBin qw/$Bin/; +use lib "$Bin/../lib"; + +use_ok('Catalyst::ScriptRunner'); + +is Catalyst::ScriptRunner->run('ScriptTestApp', 'Foo'), 'ScriptTestApp::Script::Foo', + 'Script existing only in app'; +is Catalyst::ScriptRunner->run('ScriptTestApp', 'Bar'), 'ScriptTestApp::Script::Bar', + 'Script existing in both app and Catalyst - prefers app'; +is Catalyst::ScriptRunner->run('ScriptTestApp', 'Baz'), 'Catalyst::Script::Baz', + 'Script existing only in Catalyst'; +# +1 test for the params passed to new_with_options in t/lib/Catalyst/Script/Baz.pm +{ + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= shift }; + is 'Catalyst::Script::CompileTest', Catalyst::ScriptRunner->run('ScriptTestApp', 'CompileTest'); + like $warnings, qr/Does not compile/; + like $warnings, qr/Could not load ScriptTestApp::Script::CompileTest - falling back to Catalyst::Script::CompileTest/; +} + +done_testing; diff --git a/t/author/http-server.t b/t/author/http-server.t index d4a2183..8f60174 100644 --- a/t/author/http-server.t +++ b/t/author/http-server.t @@ -32,7 +32,7 @@ rmtree '../t/tmp/TestApp/t' or die; # spawn the standalone HTTP server my $port = 30000 + int rand(1 + 10000); my @cmd = ($^X, "-I$FindBin::Bin/../../lib", - "$FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl", '-port', $port ); + "$FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl", '--port', $port ); my $pid = open3( undef, my $server, undef, @cmd) or die "Unable to spawn standalone HTTP server: $!"; diff --git a/t/lib/Catalyst/Script/Bar.pm b/t/lib/Catalyst/Script/Bar.pm new file mode 100644 index 0000000..18e699c --- /dev/null +++ b/t/lib/Catalyst/Script/Bar.pm @@ -0,0 +1,9 @@ +package Catalyst::Script::Bar; +use Moose; +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +sub run { __PACKAGE__ } + +1; diff --git a/t/lib/Catalyst/Script/Baz.pm b/t/lib/Catalyst/Script/Baz.pm new file mode 100644 index 0000000..d699fe6 --- /dev/null +++ b/t/lib/Catalyst/Script/Baz.pm @@ -0,0 +1,16 @@ +package Catalyst::Script::Baz; +use Moose; +use namespace::autoclean; + +use Test::More; + +with 'Catalyst::ScriptRole'; + +sub run { __PACKAGE__ } + +after new_with_options => sub { + my ($self, %args) = @_; + is_deeply \%args, { application_name => 'ScriptTestApp' }, 'App name correct'; +}; + +1; diff --git a/t/lib/ScriptTestApp/Script/Bar.pm b/t/lib/ScriptTestApp/Script/Bar.pm new file mode 100644 index 0000000..1d01fad --- /dev/null +++ b/t/lib/ScriptTestApp/Script/Bar.pm @@ -0,0 +1,9 @@ +package ScriptTestApp::Script::Bar; +use Moose; +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +sub run { __PACKAGE__ } + +1; \ No newline at end of file diff --git a/t/lib/ScriptTestApp/Script/Foo.pm b/t/lib/ScriptTestApp/Script/Foo.pm new file mode 100644 index 0000000..8d61c63 --- /dev/null +++ b/t/lib/ScriptTestApp/Script/Foo.pm @@ -0,0 +1,9 @@ +package ScriptTestApp::Script::Foo; +use Moose; +use namespace::autoclean; + +with 'Catalyst::ScriptRole'; + +sub run { __PACKAGE__ } + +1; diff --git a/t/lib/TestAppToTestScripts.pm b/t/lib/TestAppToTestScripts.pm new file mode 100644 index 0000000..f32154a --- /dev/null +++ b/t/lib/TestAppToTestScripts.pm @@ -0,0 +1,14 @@ +package TestAppToTestScripts; +use strict; +use warnings; +use Carp; + +our @RUN_ARGS; + +sub run { + @RUN_ARGS = @_; + 1; # Does this work? +} + +1; +