use Module::Build;
my $build = Module::Build->new(
+ create_makefile_pl => 'passthrough',
license => 'perl',
module_name => 'Catalyst',
requires => {
'perl' => '5.8.1',
'UNIVERSAL::require' => 0,
- 'CGI' => '3.06',
'Class::Accessor::Fast' => 0,
'Class::Data::Inheritable' => 0,
- 'File::Temp' => 0.14,
- 'HTTP::Daemon' => 0,
+ 'CGI::Cookie' => 0,
'HTML::Entities' => 0,
+ 'HTTP::Body' => 0,
'HTTP::Headers' => 1.59,
'HTTP::Request' => 0,
'HTTP::Response' => 0,
'LWP::UserAgent' => 0,
'Module::Pluggable::Fast' => 0.16,
+ 'NEXT' => 0,
'Path::Class' => 0.09,
+ 'Scalar::Util' => 0,
'Template' => 0,
'Text::ASCIITable' => 0.17,
+ 'Test::MockObject' => 0,
'Tree::Simple' => 0,
'Tree::Simple::Visitor::FindByPath' => 0,
- 'URI' => 0,
- 'Time::HiRes' => 0,
+ 'URI' => 1.35,
+ 'URI::Query' => 0,
},
- create_makefile_pl => 'passthrough',
- create_readme => 1,
- script_files => [ glob('script/*') ],
- test_files => "t/",
- recursive_test_files => 1
+ recommends => { 'Catalyst::Engine::Apache' => 0, },
+ create_makefile_pl => 'passthrough',
+ create_readme => 1,
+ script_files => [ glob('script/*') ],
+ test_files => [
+ glob('t/*.t'), glob('t/*/*.t'),
+ glob('t/*/*/*.t'), glob('t/*/*/*/*.t'),
+ glob('t/*/*/*/*/*.t')
+ ]
);
$build->create_build_script;
print( '*' x 80, "\n" );
print(
- (qw/chansen draven fordmason naughton sri the_jester/)[ int( rand(6) ) ],
+ (qw/andyg chansen draven fordmason mst naughton sri jester/)
+ [ int( rand(8) ) ],
" is the greatest and gabb is ",
( (localtime)[2] > 12 ? "drunk" : "hung over" ),
" again!\n"
eval "use FCGI";
print qq/Install "FCGI" for FastCGI support.\n/ if $@;
+
+print qq/
+*** IMPORTANT NOTE: ***
+The Apache engines have been moved to a separate package in Catalyst 5.5.
+Please install Catalyst::Engine::Apache if you need Apache support.
+/;
-This file documents the revision history for Perl extension Catalyst.
-
-5.34
+Tis file documents the revision history for Perl extension Catalyst.
+
+5.49_01 2005-10-10 10:15:00
+ - Refactored all internals, should be 99% compatible to previous
+ versions.
+ - *IMPORTANT* The Apache engines have been moved to a separate package
+ for this release. Please install Catalyst::Engine::Apache if you
+ need Apache support.
+
+ - Added support for calling forward with arguments in the path, i.e.
+ $c->forward('/foo/bar/arg1/arg2')
+ - Made $c->req->uri a URI object, added req->path_info for CGI compat.
+ Raw query string is available as $c->req->uri->query.
+ - Made $c->req->base a URI object.
+ - Parameters with multiple values (?a=1&a=2) now display properly
+ in the debug output.
+ - Semi-colon separators in query strings now work properly.
+ - Expanded documentation of catalyst.pl (Andrew Ford)
+ - Added support for running as a backend server behind a frontend
+ proxy so req->base and req->address are set properly.
+ - Added an 'abort' method to the Log api, so that you can
+ kill loggging for a whole request.
+ - Added $c->uri_for method to simplify url handling.
+ - Added more tests and reorganized the t directory.
+ - Reimplemented core engines, all are now CGI based for better test
+ coverage and maintainability.
+ - Added fork support to built in test server.
+ - Fixed all memory leaks.
+ - Thread-related bug fixes and tests. We now believe the Catalyst
+ core to be thread-safe.
+ - Added streaming IO support through $c->req->read() and
+ $c->res->write()
+ - Added MyApp->config->{parse_on_demand} (streaming input)
+ - Added $c->req->handle and $c->res->handle
+ - Improved documentation
+
+5.34 (not released)
- Fixed mkpath in Catalyst::Helper (Autrijus Tang)
- added $c->req->full_uri method (Jesse Sheidlower)
- Fixed bug in dispatcher where an invalid path could call a valid
action. (Andy Grundman)
- Fixed Helper so it works with CRLF line-endings. (Andy Grundman)
- - Require Text::ASCIITable 0.17 to fix memory leak in debug mode.
5.33 2005-08-10 15:25:00
- Now with updated manifest.
Build.PL
Changes
lib/Catalyst.pm
+lib/Catalyst/Action.pm
lib/Catalyst/Base.pm
lib/Catalyst/Build.pm
lib/Catalyst/Dispatcher.pm
lib/Catalyst/Engine.pm
-lib/Catalyst/Engine/Apache.pm
-lib/Catalyst/Engine/Apache/Base.pm
-lib/Catalyst/Engine/Apache/MP13.pm
-lib/Catalyst/Engine/Apache/MP13/Apreq.pm
-lib/Catalyst/Engine/Apache/MP13/Base.pm
-lib/Catalyst/Engine/Apache/MP19.pm
-lib/Catalyst/Engine/Apache/MP19/Apreq.pm
-lib/Catalyst/Engine/Apache/MP19/Base.pm
-lib/Catalyst/Engine/Apache/MP20.pm
-lib/Catalyst/Engine/Apache/MP20/Apreq.pm
-lib/Catalyst/Engine/Apache/MP20/Base.pm
lib/Catalyst/Engine/CGI.pm
-lib/Catalyst/Engine/CGI/APR.pm
-lib/Catalyst/Engine/CGI/Base.pm
lib/Catalyst/Engine/FastCGI.pm
-lib/Catalyst/Engine/FastCGI/APR.pm
-lib/Catalyst/Engine/FastCGI/Base.pm
lib/Catalyst/Engine/HTTP.pm
-lib/Catalyst/Engine/HTTP/Base.pm
-lib/Catalyst/Engine/HTTP/Daemon.pm
-lib/Catalyst/Engine/SpeedyCGI.pm
-lib/Catalyst/Engine/SpeedyCGI/Base.pm
lib/Catalyst/Engine/Test.pm
lib/Catalyst/Exception.pm
lib/Catalyst/Helper.pm
lib/Catalyst/Request.pm
lib/Catalyst/Request/Upload.pm
lib/Catalyst/Response.pm
-lib/Catalyst/Setup.pm
lib/Catalyst/Test.pm
lib/Catalyst/Utils.pm
Makefile.PL
t/01use.t
t/02pod.t
t/03podcoverage.t
-t/component/controller/action/begin.t
-t/component/controller/action/default.t
-t/component/controller/action/end.t
-t/component/controller/action/forward.t
-t/component/controller/action/global.t
-t/component/controller/action/inheritance.t
-t/component/controller/action/local.t
-t/component/controller/action/path.t
-t/component/controller/action/private.t
-t/component/controller/action/regexp.t
-t/engine/request/body.t
-t/engine/request/cookies.t
-t/engine/request/headers.t
-t/engine/request/parameters.t
-t/engine/request/uploads.t
-t/engine/response/cookies.t
-t/engine/response/errors.t
-t/engine/response/headers.t
-t/engine/response/redirect.t
-t/engine/response/status.t
-t/engine/setup/basics.t
-t/lib/Catalyst/Plugin/Test/Errors.pm
-t/lib/Catalyst/Plugin/Test/Headers.pm
-t/lib/TestApp.pm
-t/lib/TestApp/Controller/Action.pm
-t/lib/TestApp/Controller/Action/Begin.pm
-t/lib/TestApp/Controller/Action/Default.pm
-t/lib/TestApp/Controller/Action/End.pm
-t/lib/TestApp/Controller/Action/Forward.pm
-t/lib/TestApp/Controller/Action/Global.pm
-t/lib/TestApp/Controller/Action/Inheritance.pm
-t/lib/TestApp/Controller/Action/Local.pm
-t/lib/TestApp/Controller/Action/Path.pm
-t/lib/TestApp/Controller/Action/Private.pm
-t/lib/TestApp/Controller/Action/Regexp.pm
-t/lib/TestApp/Controller/Dump.pm
-t/lib/TestApp/Controller/Engine/Request/Uploads.pm
-t/lib/TestApp/Controller/Engine/Response/Cookies.pm
-t/lib/TestApp/Controller/Engine/Response/Errors.pm
-t/lib/TestApp/Controller/Engine/Response/Headers.pm
-t/lib/TestApp/Controller/Engine/Response/Redirect.pm
-t/lib/TestApp/Controller/Engine/Response/Status.pm
-t/lib/TestApp/View/Dump.pm
-t/lib/TestApp/View/Dump/False.pm
-t/lib/TestApp/View/Dump/Parameters.pm
-t/lib/TestApp/View/Dump/Request.pm
-t/lib/TestApp/View/Dump/Response.pm
-t/plugin/loaded.t
-t/TODO
+t/live/component/controller/action/begin.t
+t/live/component/controller/action/default.t
+t/live/component/controller/action/detach.t
+t/live/component/controller/action/end.t
+t/live/component/controller/action/forward.t
+t/live/component/controller/action/global.t
+t/live/component/controller/action/inheritance.t
+t/live/component/controller/action/local.t
+t/live/component/controller/action/path.t
+t/live/component/controller/action/private.t
+t/live/component/controller/action/regexp.t
+t/live/component/controller/action/streaming.t
+t/live/engine/request/body.t
+t/live/engine/request/cookies.t
+t/live/engine/request/headers.t
+t/live/engine/request/parameters.t
+t/live/engine/request/uploads.t
+t/live/engine/request/uri.t
+t/live/engine/response/cookies.t
+t/live/engine/response/errors.t
+t/live/engine/response/headers.t
+t/live/engine/response/large.t
+t/live/engine/response/redirect.t
+t/live/engine/response/status.t
+t/live/engine/setup/basics.t
+t/live/engine/setup/plugins.t
+t/live/lib/Catalyst/Plugin/Test/Errors.pm
+t/live/lib/Catalyst/Plugin/Test/Headers.pm
+t/live/lib/Catalyst/Plugin/Test/Plugin.pm
+t/live/lib/TestApp.pm
+t/live/lib/TestApp/Controller/Action.pm
+t/live/lib/TestApp/Controller/Action/Begin.pm
+t/live/lib/TestApp/Controller/Action/Default.pm
+t/live/lib/TestApp/Controller/Action/Detach.pm
+t/live/lib/TestApp/Controller/Action/End.pm
+t/live/lib/TestApp/Controller/Action/Forward.pm
+t/live/lib/TestApp/Controller/Action/Global.pm
+t/live/lib/TestApp/Controller/Action/Inheritance.pm
+t/live/lib/TestApp/Controller/Action/Local.pm
+t/live/lib/TestApp/Controller/Action/Path.pm
+t/live/lib/TestApp/Controller/Action/Private.pm
+t/live/lib/TestApp/Controller/Action/Regexp.pm
+t/live/lib/TestApp/Controller/Action/Streaming.pm
+t/live/lib/TestApp/Controller/Dump.pm
+t/live/lib/TestApp/Controller/Engine/Request/Uploads.pm
+t/live/lib/TestApp/Controller/Engine/Request/URI.pm
+t/live/lib/TestApp/Controller/Engine/Response/Cookies.pm
+t/live/lib/TestApp/Controller/Engine/Response/Errors.pm
+t/live/lib/TestApp/Controller/Engine/Response/Headers.pm
+t/live/lib/TestApp/Controller/Engine/Response/Large.pm
+t/live/lib/TestApp/Controller/Engine/Response/Redirect.pm
+t/live/lib/TestApp/Controller/Engine/Response/Status.pm
+t/live/lib/TestApp/View/Dump.pm
+t/live/lib/TestApp/View/Dump/Parameters.pm
+t/live/lib/TestApp/View/Dump/Request.pm
+t/live/lib/TestApp/View/Dump/Response.pm
+t/live/plugin/loaded.t
+t/unit/core/component.t
+t/unit/core/threads.t
+t/unit/core/uri_for.t
--- /dev/null
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+,v$
+\B\.svn\b
+
+# Avoid Makemaker generated and utility files.
+\bMakefile$
+\bblib
+\bMakeMaker-\d
+\bpm_to_blib$
+\bblibdirs$
+^MANIFEST\.SKIP$
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build
+
+# Avoid temp and backup files.
+~$
+\.tmp$
+\.old$
+\.bak$
+\#$
+\b\.#
---
name: Catalyst
-version: 5.33
+version: 5.49_01
author:
- 'Sebastian Riedel, C<sri@oook.de>'
abstract: The Elegant MVC Web Application Framework
license: perl
requires:
- CGI: 3.06
+ CGI::Cookie: 0
Class::Accessor::Fast: 0
Class::Data::Inheritable: 0
- File::Temp: 0.14
HTML::Entities: 0
- HTTP::Daemon: 0
+ HTTP::Body: 0
HTTP::Headers: 1.59
HTTP::Request: 0
HTTP::Response: 0
LWP::UserAgent: 0
Module::Pluggable::Fast: 0.16
+ NEXT: 0
Path::Class: 0.09
+ Scalar::Util: 0
Template: 0
- Text::ASCIITable: 0
+ Test::MockObject: 0
+ Text::ASCIITable: 0.17
Tree::Simple: 0
Tree::Simple::Visitor::FindByPath: 0
UNIVERSAL::require: 0
- URI: 0
+ URI: 1.35
+ URI::Query: 0
perl: 5.8.1
+recommends:
+ Catalyst::Engine::Apache: 0
provides:
Catalyst:
file: lib/Catalyst.pm
- version: 5.33
+ version: 5.49_01
+ Catalyst::Action:
+ file: lib/Catalyst/Action.pm
Catalyst::Base:
file: lib/Catalyst/Base.pm
Catalyst::Build:
file: lib/Catalyst/Dispatcher.pm
Catalyst::Engine:
file: lib/Catalyst/Engine.pm
- Catalyst::Engine::Apache:
- file: lib/Catalyst/Engine/Apache.pm
- Catalyst::Engine::Apache::Base:
- file: lib/Catalyst/Engine/Apache/Base.pm
- Catalyst::Engine::Apache::MP13:
- file: lib/Catalyst/Engine/Apache/MP13.pm
- Catalyst::Engine::Apache::MP13::Apreq:
- file: lib/Catalyst/Engine/Apache/MP13/Apreq.pm
- Catalyst::Engine::Apache::MP13::Base:
- file: lib/Catalyst/Engine/Apache/MP13/Base.pm
- Catalyst::Engine::Apache::MP19:
- file: lib/Catalyst/Engine/Apache/MP19.pm
- Catalyst::Engine::Apache::MP19::Apreq:
- file: lib/Catalyst/Engine/Apache/MP19/Apreq.pm
- Catalyst::Engine::Apache::MP19::Base:
- file: lib/Catalyst/Engine/Apache/MP19/Base.pm
- Catalyst::Engine::Apache::MP20:
- file: lib/Catalyst/Engine/Apache/MP20.pm
- Catalyst::Engine::Apache::MP20::Apreq:
- file: lib/Catalyst/Engine/Apache/MP20/Apreq.pm
- Catalyst::Engine::Apache::MP20::Base:
- file: lib/Catalyst/Engine/Apache/MP20/Base.pm
Catalyst::Engine::CGI:
file: lib/Catalyst/Engine/CGI.pm
- Catalyst::Engine::CGI::APR:
- file: lib/Catalyst/Engine/CGI/APR.pm
- Catalyst::Engine::CGI::Base:
- file: lib/Catalyst/Engine/CGI/Base.pm
Catalyst::Engine::FastCGI:
file: lib/Catalyst/Engine/FastCGI.pm
- Catalyst::Engine::FastCGI::APR:
- file: lib/Catalyst/Engine/FastCGI/APR.pm
- Catalyst::Engine::FastCGI::Base:
- file: lib/Catalyst/Engine/FastCGI/Base.pm
Catalyst::Engine::HTTP:
file: lib/Catalyst/Engine/HTTP.pm
- Catalyst::Engine::HTTP::Base:
- file: lib/Catalyst/Engine/HTTP/Base.pm
- Catalyst::Engine::HTTP::Daemon:
- file: lib/Catalyst/Engine/HTTP/Daemon.pm
- Catalyst::Engine::HTTP::Daemon::Catalyst:
- file: lib/Catalyst/Engine/HTTP/Daemon.pm
- Catalyst::Engine::HTTP::Daemon::Client:
- file: lib/Catalyst/Engine/HTTP/Daemon.pm
- Catalyst::Engine::SpeedyCGI:
- file: lib/Catalyst/Engine/SpeedyCGI.pm
- Catalyst::Engine::SpeedyCGI::Base:
- file: lib/Catalyst/Engine/SpeedyCGI/Base.pm
Catalyst::Engine::Test:
file: lib/Catalyst/Engine/Test.pm
Catalyst::Exception:
file: lib/Catalyst/Request/Upload.pm
Catalyst::Response:
file: lib/Catalyst/Response.pm
- Catalyst::Setup:
- file: lib/Catalyst/Setup.pm
Catalyst::Test:
file: lib/Catalyst/Test.pm
Catalyst::Utils:
file: lib/Catalyst/Utils.pm
-generated_by: Module::Build version 0.26
+generated_by: Module::Build version 0.2611
use Catalyst;
sub debug { 1 }
+ -Dispatcher
+ Force Catalyst to use a specific dispatcher.
+
-Engine
Force Catalyst to use a specific engine. Omit the
"Catalyst::Engine::" prefix of the engine name, i.e.:
use Catalyst '-Engine=CGI';
+ -Home
+ Force Catalyst to use a specific home directory.
+
+ -Log
+ Specify log level.
+
METHODS
- debug
- Overload to enable debug messages.
+ $c->comp($name)
+ $c->component($name)
+ Get a component object by name.
+
+ $c->comp('MyApp::Model::MyModel')->do_stuff;
config
Returns a hashref containing your applications settings.
+ debug
+ Overload to enable debug messages.
+
+ $c->detach( $command [, \@arguments ] )
+ Like "forward" but doesn't return.
+
+ $c->dispatcher
+ Contains the dispatcher instance. Stringifies to class.
+
+ $c->forward( $command [, \@arguments ] )
+ Forward processing to a private action or a method from a class. If
+ you define a class without method it will default to process(). also
+ takes an optional arrayref containing arguments to be passed to the
+ new function. $c->req->args will be reset upon returning from the
+ function.
+
+ $c->forward('/foo');
+ $c->forward('index');
+ $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
+ $c->forward('MyApp::View::TT');
+
+ $c->setup
+ Setup.
+
+ $c->setup;
+
+ $c->uri_for($path)
+ Merges path with $c->request->base for absolute uri's and with
+ $c->request->match for relative uri's, then returns a normalized URI
+ object.
+
+ $c->error
+ $c->error($error, ...)
+ $c->error($arrayref)
+ Returns an arrayref containing error messages.
+
+ my @error = @{ $c->error };
+
+ Add a new error.
+
+ $c->error('Something bad happened');
+
$c->engine
- Contains the engine class.
+ Contains the engine instance. Stringifies to the class.
$c->log
Contains the logging object. Unless it is already set Catalyst sets
$c->prototype->define_javascript_functions;
+ $c->request
+ $c->req
+ Returns a "Catalyst::Request" object.
+
+ my $req = $c->req;
+
+ $c->response
+ $c->res
+ Returns a "Catalyst::Response" object.
+
+ my $res = $c->res;
+
+ $c->state
+ Contains the return value of the last executed action.
+
+ $c->stash
+ Returns a hashref containing all your data.
+
+ $c->stash->{foo} ||= 'yada';
+ print $c->stash->{foo};
+
+INTERNAL METHODS
+ $c->benchmark($coderef)
+ Takes a coderef with arguments and returns elapsed time as float.
+
+ my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
+ $c->log->info( sprintf "Processing took %f seconds", $elapsed );
+
+ $c->components
+ Contains the components.
+
+ $c->counter
+ Returns a hashref containing coderefs and execution counts. (Needed
+ for deep recursion detection)
+
+ $c->depth
+ Returns the actual forward depth.
+
+ $c->dispatch
+ Dispatch request to actions.
+
+ $c->execute($class, $coderef)
+ Execute a coderef in given class and catch exceptions. Errors are
+ available via $c->error.
+
+ $c->finalize
+ Finalize request.
+
+ $c->finalize_body
+ Finalize body.
+
+ $c->finalize_cookies
+ Finalize cookies.
+
+ $c->finalize_error
+ Finalize error.
+
+ $c->finalize_headers
+ Finalize headers.
+
+ $c->finalize_output
+ An alias for finalize_body.
+
+ $c->finalize_read
+ Finalize the input after reading is complete.
+
+ $c->finalize_uploads
+ Finalize uploads. Cleans up any temporary files.
+
+ $c->get_action( $action, $namespace, $inherit )
+ Get an action in a given namespace.
+
+ handle_request( $class, @arguments )
+ Handles the request.
+
+ $c->prepare(@arguments)
+ Turns the engine-specific request( Apache, CGI ... ) into a Catalyst
+ context .
+
+ $c->prepare_action
+ Prepare action.
+
+ $c->prepare_body
+ Prepare message body.
+
+ $c->prepare_body_parameters
+ Prepare body parameters.
+
+ $c->prepare_connection
+ Prepare connection.
+
+ $c->prepare_cookies
+ Prepare cookies.
+
+ $c->prepare_headers
+ Prepare headers.
+
+ $c->prepare_parameters
+ Prepare parameters.
+
+ $c->prepare_path
+ Prepare path and base.
+
+ $c->prepare_query_parameters
+ Prepare query parameters.
+
+ $c->prepare_read
+ Prepare the input for reading.
+
+ $c->prepare_request
+ Prepare the engine request.
+
+ $c->prepare_uploads
+ Prepare uploads.
+
+ $c->prepare_write
+ Prepare the output for writing.
+
+ $c->read( [$maxlength] )
+ Read a chunk of data from the request body. This method is designed
+ to be used in a while loop, reading $maxlength bytes on every call.
+ $maxlength defaults to the size of the request if not specified.
+
+ You have to set MyApp->config->{parse_on_demand} to use this
+ directly.
+
+ $c->run
+ Starts the engine.
+
+ $c->set_action( $action, $code, $namespace, $attrs )
+ Set an action in a given namespace.
+
+ $c->setup_actions($component)
+ Setup actions for a component.
+
+ $c->setup_components
+ Setup components.
+
+ $c->setup_dispatcher
+ $c->setup_engine
+ $c->setup_home
+ $c->setup_log
+ $c->setup_plugins
+ $c->write( $data )
+ Writes $data to the output stream. When using this method directly,
+ you will need to manually set the Content-Length header to the
+ length of your output data, if known.
+
CASE SENSITIVITY
By default Catalyst is not case sensitive, so "MyApp::C::FOO::Bar"
becomes "/foo/bar".
MyApp->config->{case_sensitive} = 1;
-LIMITATIONS
- mod_perl2 support is considered experimental and may contain bugs.
+ So "MyApp::C::Foo::Bar" becomes "/Foo/Bar".
+
+ON-DEMAND PARSER
+ The request body is usually parsed at the beginning of a request, but if
+ you want to handle input yourself or speed things up a bit you can
+ enable on-demand parsing with a config parameter.
+
+ MyApp->config->{parse_on_demand} = 1;
+
+PROXY SUPPORT
+ Many production servers operate using the common double-server approach,
+ with a lightweight frontend web server passing requests to a larger
+ backend server. An application running on the backend server must deal
+ with two problems: the remote user always appears to be '127.0.0.1' and
+ the server's hostname will appear to be 'localhost' regardless of the
+ virtual host the user connected through.
+
+ Catalyst will automatically detect this situation when you are running
+ both the frontend and backend servers on the same machine. The following
+ changes are made to the request.
+
+ $c->req->address is set to the user's real IP address, as read from the
+ HTTP_X_FORWARDED_FOR header.
+
+ The host value for $c->req->base and $c->req->uri is set to the real host,
+ as read from the HTTP_X_FORWARDED_HOST header.
+
+ Obviously, your web server must support these 2 headers for this to
+ work.
+
+ In a more complex server farm environment where you may have your
+ frontend proxy server(s) on different machines, you will need to set a
+ configuration option to tell Catalyst to read the proxied data from the
+ headers.
+
+ MyApp->config->{using_frontend_proxy} = 1;
+
+ If you do not wish to use the proxy support at all, you may set:
+
+ MyApp->config->{ignore_frontend_proxy} = 1;
+
+THREAD SAFETY
+ Catalyst has been tested under Apache 2's threading mpm_worker,
+ mpm_winnt, and the standalone forking HTTP server on Windows. We believe
+ the Catalyst core to be thread-safe.
+
+ If you plan to operate in a threaded environment, remember that all
+ other modules you are using must also be thread-safe. Some modules, most
+ notably DBD::SQLite, are not thread-safe.
SUPPORT
IRC:
CREDITS
Andy Grundman
+ Andy Wardley
+
Andrew Ford
Andrew Ruthven
+ Arthur Bergman
+
Autrijus Tang
Christian Hansen
Jesse Sheidlower
+ Jesse Vincent
+
Jody Belka
Johan Lindstrom
Robert Sedlacek
- Sebastian Riedel
-
Tatsuhiko Miyagawa
Ulf Edvinsson
package Catalyst;
use strict;
-use base qw[ Catalyst::Base Catalyst::Setup ];
+use base 'Catalyst::Base';
+use bytes;
use UNIVERSAL::require;
use Catalyst::Exception;
use Catalyst::Log;
+use Catalyst::Request;
+use Catalyst::Request::Upload;
+use Catalyst::Response;
use Catalyst::Utils;
use NEXT;
+use Text::ASCIITable;
use Path::Class;
-our $CATALYST_SCRIPT_GEN = 4;
+use Time::HiRes qw/gettimeofday tv_interval/;
+use URI;
+use Scalar::Util qw/weaken/;
-__PACKAGE__->mk_classdata($_) for qw/arguments dispatcher engine log/;
+__PACKAGE__->mk_accessors(qw/counter depth request response state/);
-our $VERSION = '5.34';
-our @ISA;
+# Laziness++
+*comp = \&component;
+*req = \&request;
+*res = \&response;
+
+# For backwards compatibility
+*finalize_output = \&finalize_body;
+
+# For statistics
+our $COUNT = 1;
+our $START = time;
+our $RECURSION = 1000;
+our $DETACH = "catalyst_detach\n";
+
+require Module::Pluggable::Fast;
+
+# Helper script generation
+our $CATALYST_SCRIPT_GEN = 6;
+
+__PACKAGE__->mk_classdata($_)
+ for qw/components arguments dispatcher engine log/;
+
+our $VERSION = '5.49_01';
+
+sub import {
+ my ( $class, @arguments ) = @_;
+
+ # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
+ # callers @ISA.
+ return unless $class eq 'Catalyst';
+
+ my $caller = caller(0);
+
+ unless ( $caller->isa('Catalyst') ) {
+ no strict 'refs';
+ push @{"$caller\::ISA"}, $class;
+ }
+
+ $caller->arguments( [@arguments] );
+ $caller->setup_home;
+}
=head1 NAME
use Catalyst;
sub debug { 1 }
+=item -Dispatcher
+
+Force Catalyst to use a specific dispatcher.
+
=item -Engine
Force Catalyst to use a specific engine.
use Catalyst '-Engine=CGI';
+=item -Home
+
+Force Catalyst to use a specific home directory.
+
+=item -Log
+
+Specify log level.
+
=back
=head1 METHODS
=over 4
+=item $c->comp($name)
+
+=item $c->component($name)
+
+Get a component object by name.
+
+ $c->comp('MyApp::Model::MyModel')->do_stuff;
+
+=cut
+
+sub component {
+ my $c = shift;
+
+ if (@_) {
+
+ my $name = shift;
+
+ my $appclass = ref $c || $c;
+
+ my @names = (
+ $name, "${appclass}::${name}",
+ map { "${appclass}::${_}::${name}" } qw/M V C/
+ );
+
+ foreach my $try (@names) {
+
+ if ( exists $c->components->{$try} ) {
+
+ return $c->components->{$try};
+ }
+ }
+
+ foreach my $component ( keys %{ $c->components } ) {
+
+ return $c->components->{$component} if $component =~ /$name/i;
+ }
+
+ }
+
+ return sort keys %{ $c->components };
+}
+
+=item config
+
+Returns a hashref containing your applications settings.
+
=item debug
Overload to enable debug messages.
sub debug { 0 }
-=item config
+=item $c->detach( $command [, \@arguments ] )
-Returns a hashref containing your applications settings.
+Like C<forward> but doesn't return.
=cut
-sub import {
+sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
+
+=item $c->dispatcher
+
+Contains the dispatcher instance.
+Stringifies to class.
+
+=item $c->forward( $command [, \@arguments ] )
+
+Forward processing to a private action or a method from a class.
+If you define a class without method it will default to process().
+also takes an optional arrayref containing arguments to be passed
+to the new function. $c->req->args will be reset upon returning
+from the function.
+
+ $c->forward('/foo');
+ $c->forward('index');
+ $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
+ $c->forward('MyApp::View::TT');
+
+=cut
+
+sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
+
+=item $c->setup
+
+Setup.
+
+ $c->setup;
+
+=cut
+
+sub setup {
my ( $class, @arguments ) = @_;
-
- # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
- # callers @ISA.
- return unless $class eq 'Catalyst';
- my $caller = caller(0);
+ unless ( $class->isa('Catalyst') ) {
- unless ( $caller->isa('Catalyst') ) {
- no strict 'refs';
- push @{"$caller\::ISA"}, $class;
+ Catalyst::Exception->throw(
+ message => qq/'$class' does not inherit from Catalyst/ );
}
- $caller->arguments( [ @arguments ] );
- $caller->setup_home;
+ if ( $class->arguments ) {
+ @arguments = ( @arguments, @{ $class->arguments } );
+ }
+
+ # Process options
+ my $flags = {};
+
+ foreach (@arguments) {
+
+ if (/^-Debug$/) {
+ $flags->{log} =
+ ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
+ }
+ elsif (/^-(\w+)=?(.*)$/) {
+ $flags->{ lc $1 } = $2;
+ }
+ else {
+ push @{ $flags->{plugins} }, $_;
+ }
+ }
+
+ $class->setup_log( delete $flags->{log} );
+ $class->setup_plugins( delete $flags->{plugins} );
+ $class->setup_dispatcher( delete $flags->{dispatcher} );
+ $class->setup_engine( delete $flags->{engine} );
+ $class->setup_home( delete $flags->{home} );
+
+ for my $flag ( sort keys %{$flags} ) {
+
+ if ( my $code = $class->can( 'setup_' . $flag ) ) {
+ &$code( $class, delete $flags->{$flag} );
+ }
+ else {
+ $class->log->warn(qq/Unknown flag "$flag"/);
+ }
+ }
+
+ $class->log->warn( "You are running an old helper script! "
+ . "Please update your scripts by regenerating the "
+ . "application and copying over the new scripts." )
+ if ( $ENV{CATALYST_SCRIPT_GEN}
+ && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
+
+ if ( $class->debug ) {
+
+ my @plugins = ();
+
+ {
+ no strict 'refs';
+ @plugins = grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
+ }
+
+ if (@plugins) {
+ my $t = Text::ASCIITable->new;
+ $t->setOptions( 'hide_HeadRow', 1 );
+ $t->setOptions( 'hide_HeadLine', 1 );
+ $t->setCols('Class');
+ $t->setColWidth( 'Class', 75, 1 );
+ $t->addRow($_) for @plugins;
+ $class->log->debug( "Loaded plugins:\n" . $t->draw );
+ }
+
+ my $dispatcher = $class->dispatcher;
+ my $engine = $class->engine;
+ my $home = $class->config->{home};
+
+ $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
+ $class->log->debug(qq/Loaded engine "$engine"/);
+
+ $home
+ ? ( -d $home )
+ ? $class->log->debug(qq/Found home "$home"/)
+ : $class->log->debug(qq/Home "$home" doesn't exist/)
+ : $class->log->debug(q/Couldn't find home/);
+ }
+
+ # Call plugins setup
+ {
+ no warnings qw/redefine/;
+ local *setup = sub { };
+ $class->setup;
+ }
+
+ # Initialize our data structure
+ $class->components( {} );
+
+ $class->setup_components;
+
+ if ( $class->debug ) {
+ my $t = Text::ASCIITable->new;
+ $t->setOptions( 'hide_HeadRow', 1 );
+ $t->setOptions( 'hide_HeadLine', 1 );
+ $t->setCols('Class');
+ $t->setColWidth( 'Class', 75, 1 );
+ $t->addRow($_) for sort keys %{ $class->components };
+ $class->log->debug( "Loaded components:\n" . $t->draw )
+ if ( @{ $t->{tbl_rows} } );
+ }
+
+ # Add our self to components, since we are also a component
+ $class->components->{$class} = $class;
+
+ $class->setup_actions;
+
+ if ( $class->debug ) {
+ my $name = $class->config->{name} || 'Application';
+ $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
+ }
+ $class->log->_flush() if $class->log->can('_flush');
+}
+
+=item $c->uri_for($path)
+
+Merges path with $c->request->base for absolute uri's and with
+$c->request->match for relative uri's, then returns a normalized
+L<URI> object.
+
+=cut
+
+sub uri_for {
+ my ( $c, $path ) = @_;
+ my $base = $c->request->base->clone;
+ my $basepath = $base->path;
+ $basepath =~ s/\/$//;
+ $basepath .= '/' if $basepath;
+ my $match = $c->request->match;
+ $match =~ s/^\///;
+ $match .= '/' if $match;
+ $match = '' if $path =~ /^\//;
+ $path =~ s/^\///;
+ return URI->new_abs( URI->new_abs( $path, "$basepath$match" ), $base )
+ ->canonical;
+}
+
+=item $c->error
+
+=item $c->error($error, ...)
+
+=item $c->error($arrayref)
+
+Returns an arrayref containing error messages.
+
+ my @error = @{ $c->error };
+
+Add a new error.
+
+ $c->error('Something bad happened');
+
+=cut
+
+sub error {
+ my $c = shift;
+ my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
+ push @{ $c->{error} }, @$error;
+ return $c->{error};
}
=item $c->engine
-Contains the engine class.
+Contains the engine instance.
+Stringifies to the class.
=item $c->log
if ( my $error = $UNIVERSAL::require::ERROR ) {
Catalyst::Exception->throw(
- message => qq/Couldn't load instant plugin "$plugin", "$error"/
- );
+ message => qq/Couldn't load instant plugin "$plugin", "$error"/ );
}
eval { $plugin->import };
my $obj;
eval { $obj = $plugin->new(@args) };
- if ( $@ ) {
- Catalyst::Exception->throw(
- message => qq/Couldn't instantiate instant plugin "$plugin", "$@"/
- );
+ if ($@) {
+ Catalyst::Exception->throw( message =>
+ qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
}
$class->$name($obj);
if $class->debug;
}
+=item $c->request
+
+=item $c->req
+
+Returns a C<Catalyst::Request> object.
+
+ my $req = $c->req;
+
+=item $c->response
+
+=item $c->res
+
+Returns a C<Catalyst::Response> object.
+
+ my $res = $c->res;
+
+=item $c->state
+
+Contains the return value of the last executed action.
+
+=item $c->stash
+
+Returns a hashref containing all your data.
+
+ $c->stash->{foo} ||= 'yada';
+ print $c->stash->{foo};
+
+=cut
+
+sub stash {
+ my $c = shift;
+ if (@_) {
+ my $stash = @_ > 1 ? {@_} : $_[0];
+ while ( my ( $key, $val ) = each %$stash ) {
+ $c->{stash}->{$key} = $val;
+ }
+ }
+ return $c->{stash};
+}
+
+=back
+
+=head1 INTERNAL METHODS
+
+=over 4
+
+=item $c->benchmark($coderef)
+
+Takes a coderef with arguments and returns elapsed time as float.
+
+ my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
+ $c->log->info( sprintf "Processing took %f seconds", $elapsed );
+
+=cut
+
+sub benchmark {
+ my $c = shift;
+ my $code = shift;
+ my $time = [gettimeofday];
+ my @return = &$code(@_);
+ my $elapsed = tv_interval $time;
+ return wantarray ? ( $elapsed, @return ) : $elapsed;
+}
+
+=item $c->components
+
+Contains the components.
+
+=item $c->counter
+
+Returns a hashref containing coderefs and execution counts.
+(Needed for deep recursion detection)
+
+=item $c->depth
+
+Returns the actual forward depth.
+
+=item $c->dispatch
+
+Dispatch request to actions.
+
+=cut
+
+sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
+
+=item $c->execute($class, $coderef)
+
+Execute a coderef in given class and catch exceptions.
+Errors are available via $c->error.
+
+=cut
+
+sub execute {
+ my ( $c, $class, $code ) = @_;
+ $class = $c->components->{$class} || $class;
+ $c->state(0);
+ my $callsub = ( caller(1) )[3];
+
+ my $action = '';
+ if ( $c->debug ) {
+ $action = "$code";
+ $action = "/$action" unless $action =~ /\-\>/;
+ $c->counter->{"$code"}++;
+
+ if ( $c->counter->{"$code"} > $RECURSION ) {
+ my $error = qq/Deep recursion detected in "$action"/;
+ $c->log->error($error);
+ $c->error($error);
+ $c->state(0);
+ return $c->state;
+ }
+
+ $action = "-> $action" if $callsub =~ /forward$/;
+ }
+ $c->{depth}++;
+ eval {
+ if ( $c->debug )
+ {
+ my ( $elapsed, @state ) =
+ $c->benchmark( $code, $class, $c, @{ $c->req->args } );
+ push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
+ $c->state(@state);
+ }
+ else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
+ };
+ $c->{depth}--;
+
+ if ( my $error = $@ ) {
+
+ if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
+ else {
+ unless ( ref $error ) {
+ chomp $error;
+ $error = qq/Caught exception "$error"/;
+ }
+
+ $c->log->error($error);
+ $c->error($error);
+ $c->state(0);
+ }
+ }
+ return $c->state;
+}
+
+=item $c->finalize
+
+Finalize request.
+
+=cut
+
+sub finalize {
+ my $c = shift;
+
+ $c->finalize_uploads;
+
+ # Error
+ if ( $#{ $c->error } >= 0 ) {
+ $c->finalize_error;
+ }
+
+ $c->finalize_headers;
+
+ # HEAD request
+ if ( $c->request->method eq 'HEAD' ) {
+ $c->response->body('');
+ }
+
+ $c->finalize_body;
+
+ return $c->response->status;
+}
+
+=item $c->finalize_body
+
+Finalize body.
+
+=cut
+
+sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
+
+=item $c->finalize_cookies
+
+Finalize cookies.
+
+=cut
+
+sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
+
+=item $c->finalize_error
+
+Finalize error.
+
+=cut
+
+sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
+
+=item $c->finalize_headers
+
+Finalize headers.
+
+=cut
+
+sub finalize_headers {
+ my $c = shift;
+
+ # Check if we already finalized headers
+ return if $c->response->{_finalized_headers};
+
+ # Handle redirects
+ if ( my $location = $c->response->redirect ) {
+ $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
+ $c->response->header( Location => $location );
+ }
+
+ # Content-Length
+ if ( $c->response->body && !$c->response->content_length ) {
+ $c->response->content_length( bytes::length( $c->response->body ) );
+ }
+
+ # Errors
+ if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
+ $c->response->headers->remove_header("Content-Length");
+ $c->response->body('');
+ }
+
+ $c->finalize_cookies;
+
+ $c->engine->finalize_headers( $c, @_ );
+
+ # Done
+ $c->response->{_finalized_headers} = 1;
+}
+
+=item $c->finalize_output
+
+An alias for finalize_body.
+
+=item $c->finalize_read
+
+Finalize the input after reading is complete.
+
+=cut
+
+sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
+
+=item $c->finalize_uploads
+
+Finalize uploads. Cleans up any temporary files.
+
+=cut
+
+sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
+
+=item $c->get_action( $action, $namespace, $inherit )
+
+Get an action in a given namespace.
+
+=cut
+
+sub get_action { my $c = shift; $c->dispatcher->get_action( $c, @_ ) }
+
+=item handle_request( $class, @arguments )
+
+Handles the request.
+
+=cut
+
+sub handle_request {
+ my ( $class, @arguments ) = @_;
+
+ # Always expect worst case!
+ my $status = -1;
+ eval {
+ my @stats = ();
+
+ my $handler = sub {
+ my $c = $class->prepare(@arguments);
+ $c->{stats} = \@stats;
+ $c->dispatch;
+ return $c->finalize;
+ };
+
+ if ( $class->debug ) {
+ my $elapsed;
+ ( $elapsed, $status ) = $class->benchmark($handler);
+ $elapsed = sprintf '%f', $elapsed;
+ my $av = sprintf '%.3f',
+ ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
+ my $t = Text::ASCIITable->new;
+ $t->setCols( 'Action', 'Time' );
+ $t->setColWidth( 'Action', 64, 1 );
+ $t->setColWidth( 'Time', 9, 1 );
+
+ for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
+ $class->log->info(
+ "Request took ${elapsed}s ($av/s)\n" . $t->draw );
+ }
+ else { $status = &$handler }
+
+ };
+
+ if ( my $error = $@ ) {
+ chomp $error;
+ $class->log->error(qq/Caught exception in engine "$error"/);
+ }
+
+ $COUNT++;
+ $class->log->_flush() if $class->log->can('_flush');
+ return $status;
+}
+
+=item $c->prepare(@arguments)
+
+Turns the engine-specific request( Apache, CGI ... )
+into a Catalyst context .
+
+=cut
+
+sub prepare {
+ my ( $class, @arguments ) = @_;
+
+ my $c = bless {
+ counter => {},
+ depth => 0,
+ request => Catalyst::Request->new(
+ {
+ arguments => [],
+ body_parameters => {},
+ cookies => {},
+ handle => \*STDIN,
+ headers => HTTP::Headers->new,
+ parameters => {},
+ query_parameters => {},
+ secure => 0,
+ snippets => [],
+ uploads => {}
+ }
+ ),
+ response => Catalyst::Response->new(
+ {
+ body => '',
+ cookies => {},
+ handle => \*STDOUT,
+ headers => HTTP::Headers->new(),
+ status => 200
+ }
+ ),
+ stash => {},
+ state => 0
+ }, $class;
+
+ # For on-demand data
+ $c->request->{_context} = $c;
+ $c->response->{_context} = $c;
+ weaken( $c->request->{_context} );
+ weaken( $c->response->{_context} );
+
+ if ( $c->debug ) {
+ my $secs = time - $START || 1;
+ my $av = sprintf '%.3f', $COUNT / $secs;
+ $c->log->debug('**********************************');
+ $c->log->debug("* Request $COUNT ($av/s) [$$]");
+ $c->log->debug('**********************************');
+ $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
+ }
+
+ $c->prepare_request(@arguments);
+ $c->prepare_connection;
+ $c->prepare_query_parameters;
+ $c->prepare_headers;
+ $c->prepare_cookies;
+ $c->prepare_path;
+
+ # On-demand parsing
+ $c->prepare_body unless $c->config->{parse_on_demand};
+
+ $c->prepare_action;
+ my $method = $c->req->method || '';
+ my $path = $c->req->path || '';
+ my $address = $c->req->address || '';
+
+ $c->log->debug(qq/"$method" request for "$path" from $address/)
+ if $c->debug;
+
+ return $c;
+}
+
+=item $c->prepare_action
+
+Prepare action.
+
+=cut
+
+sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
+
+=item $c->prepare_body
+
+Prepare message body.
+
+=cut
+
+sub prepare_body {
+ my $c = shift;
+
+ # Do we run for the first time?
+ return if defined $c->request->{_body};
+
+ # Initialize on-demand data
+ $c->engine->prepare_body( $c, @_ );
+ $c->prepare_parameters;
+ $c->prepare_uploads;
+
+ if ( $c->debug && keys %{ $c->req->body_parameters } ) {
+ my $t = Text::ASCIITable->new;
+ $t->setCols( 'Key', 'Value' );
+ $t->setColWidth( 'Key', 37, 1 );
+ $t->setColWidth( 'Value', 36, 1 );
+ $t->alignCol( 'Value', 'right' );
+ for my $key ( sort keys %{ $c->req->body_parameters } ) {
+ my $param = $c->req->body_parameters->{$key};
+ my $value = defined($param) ? $param : '';
+ $t->addRow( $key,
+ ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
+ }
+ $c->log->debug( "Body Parameters are:\n" . $t->draw );
+ }
+}
+
+=item $c->prepare_body_parameters
+
+Prepare body parameters.
+
+=cut
+
+sub prepare_body_parameters {
+ my $c = shift;
+ $c->engine->prepare_body_parameters( $c, @_ );
+}
+
+=item $c->prepare_connection
+
+Prepare connection.
+
+=cut
+
+sub prepare_connection {
+ my $c = shift;
+ $c->engine->prepare_connection( $c, @_ );
+}
+
+=item $c->prepare_cookies
+
+Prepare cookies.
+
+=cut
+
+sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
+
+=item $c->prepare_headers
+
+Prepare headers.
+
+=cut
+
+sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
+
+=item $c->prepare_parameters
+
+Prepare parameters.
+
+=cut
+
+sub prepare_parameters {
+ my $c = shift;
+ $c->prepare_body_parameters;
+ $c->engine->prepare_parameters( $c, @_ );
+}
+
+=item $c->prepare_path
+
+Prepare path and base.
+
+=cut
+
+sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
+
+=item $c->prepare_query_parameters
+
+Prepare query parameters.
+
+=cut
+
+sub prepare_query_parameters {
+ my $c = shift;
+
+ $c->engine->prepare_query_parameters( $c, @_ );
+
+ if ( $c->debug && keys %{ $c->request->query_parameters } ) {
+ my $t = Text::ASCIITable->new;
+ $t->setCols( 'Key', 'Value' );
+ $t->setColWidth( 'Key', 37, 1 );
+ $t->setColWidth( 'Value', 36, 1 );
+ $t->alignCol( 'Value', 'right' );
+ for my $key ( sort keys %{ $c->req->query_parameters } ) {
+ my $param = $c->req->query_parameters->{$key};
+ my $value = defined($param) ? $param : '';
+ $t->addRow( $key,
+ ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
+ }
+ $c->log->debug( "Query Parameters are:\n" . $t->draw );
+ }
+}
+
+=item $c->prepare_read
+
+Prepare the input for reading.
+
+=cut
+
+sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
+
+=item $c->prepare_request
+
+Prepare the engine request.
+
+=cut
+
+sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
+
+=item $c->prepare_uploads
+
+Prepare uploads.
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+
+ $c->engine->prepare_uploads( $c, @_ );
+
+ if ( $c->debug && keys %{ $c->request->uploads } ) {
+ my $t = Text::ASCIITable->new;
+ $t->setCols( 'Filename', 'Type', 'Size' );
+ $t->setColWidth( 'Filename', 37, 1 );
+ $t->setColWidth( 'Type', 24, 1 );
+ $t->setColWidth( 'Size', 9, 1 );
+ $t->alignCol( 'Size', 'left' );
+ for my $key ( sort keys %{ $c->request->uploads } ) {
+ my $upload = $c->request->uploads->{$key};
+ for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
+ $t->addRow( $key, $u->type, $u->size );
+ }
+ }
+ $c->log->debug( "File Uploads are:\n" . $t->draw );
+ }
+}
+
+=item $c->prepare_write
+
+Prepare the output for writing.
+
+=cut
+
+sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
+
+=item $c->read( [$maxlength] )
+
+Read a chunk of data from the request body. This method is designed to be
+used in a while loop, reading $maxlength bytes on every call. $maxlength
+defaults to the size of the request if not specified.
+
+You have to set MyApp->config->{parse_on_demand} to use this directly.
+
+=cut
+
+sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
+
+=item $c->run
+
+Starts the engine.
+
+=cut
+
+sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
+
+=item $c->set_action( $action, $code, $namespace, $attrs )
+
+Set an action in a given namespace.
+
+=cut
+
+sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
+
+=item $c->setup_actions($component)
+
+Setup actions for a component.
+
+=cut
+
+sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
+
+=item $c->setup_components
+
+Setup components.
+
+=cut
+
+sub setup_components {
+ my $class = shift;
+
+ my $callback = sub {
+ my ( $component, $context ) = @_;
+
+ unless ( $component->isa('Catalyst::Base') ) {
+ return $component;
+ }
+
+ my $suffix = Catalyst::Utils::class2classsuffix($component);
+ my $config = $class->config->{$suffix} || {};
+
+ my $instance;
+
+ eval { $instance = $component->new( $context, $config ); };
+
+ if ( my $error = $@ ) {
+
+ chomp $error;
+
+ Catalyst::Exception->throw( message =>
+ qq/Couldn't instantiate component "$component", "$error"/ );
+ }
+
+ Catalyst::Exception->throw( message =>
+qq/Couldn't instantiate component "$component", "new() didn't return a object"/
+ )
+ unless ref $instance;
+ return $instance;
+ };
+
+ eval {
+ Module::Pluggable::Fast->import(
+ name => '_catalyst_components',
+ search => [
+ "$class\::Controller", "$class\::C",
+ "$class\::Model", "$class\::M",
+ "$class\::View", "$class\::V"
+ ],
+ callback => $callback
+ );
+ };
+
+ if ( my $error = $@ ) {
+
+ chomp $error;
+
+ Catalyst::Exception->throw(
+ message => qq/Couldn't load components "$error"/ );
+ }
+
+ for my $component ( $class->_catalyst_components($class) ) {
+ $class->components->{ ref $component || $component } = $component;
+ }
+}
+
+=item $c->setup_dispatcher
+
+=cut
+
+sub setup_dispatcher {
+ my ( $class, $dispatcher ) = @_;
+
+ if ($dispatcher) {
+ $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
+ }
+
+ if ( $ENV{CATALYST_DISPATCHER} ) {
+ $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
+ }
+
+ if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
+ $dispatcher =
+ 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
+ }
+
+ unless ($dispatcher) {
+ $dispatcher = 'Catalyst::Dispatcher';
+ }
+
+ $dispatcher->require;
+
+ if ($@) {
+ Catalyst::Exception->throw(
+ message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
+ }
+
+ # dispatcher instance
+ $class->dispatcher( $dispatcher->new );
+}
+
+=item $c->setup_engine
+
+=cut
+
+sub setup_engine {
+ my ( $class, $engine ) = @_;
+
+ if ($engine) {
+ $engine = 'Catalyst::Engine::' . $engine;
+ }
+
+ if ( $ENV{CATALYST_ENGINE} ) {
+ $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
+ }
+
+ if ( $ENV{ uc($class) . '_ENGINE' } ) {
+ $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
+ }
+
+ if ( !$engine && $ENV{MOD_PERL} ) {
+
+ # create the apache method
+ {
+ no strict 'refs';
+ *{"$class\::apache"} = sub { shift->engine->apache };
+ }
+
+ my ( $software, $version ) =
+ $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
+
+ $version =~ s/_//g;
+ $version =~ s/(\.[^.]+)\./$1/g;
+
+ if ( $software eq 'mod_perl' ) {
+
+ if ( $version >= 1.99922 ) {
+ $engine = 'Catalyst::Engine::Apache2::MP20';
+ }
+
+ elsif ( $version >= 1.9901 ) {
+ $engine = 'Catalyst::Engine::Apache2::MP19';
+ }
+
+ elsif ( $version >= 1.24 ) {
+ $engine = 'Catalyst::Engine::Apache::MP13';
+ }
+
+ else {
+ Catalyst::Exception->throw( message =>
+ qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
+ }
+
+ # install the correct mod_perl handler
+ if ( $version >= 1.9901 ) {
+ *handler = sub : method {
+ shift->handle_request(@_);
+ };
+ }
+ else {
+ *handler = sub ($$) { shift->handle_request(@_) };
+ }
+
+ }
+
+ elsif ( $software eq 'Zeus-Perl' ) {
+ $engine = 'Catalyst::Engine::Zeus';
+ }
+
+ else {
+ Catalyst::Exception->throw(
+ message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
+ }
+ }
+
+ unless ($engine) {
+ $engine = 'Catalyst::Engine::CGI';
+ }
+
+ $engine->require;
+
+ if ($@) {
+ Catalyst::Exception->throw( message =>
+qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
+ );
+ }
+
+ # engine instance
+ $class->engine( $engine->new );
+}
+
+=item $c->setup_home
+
+=cut
+
+sub setup_home {
+ my ( $class, $home ) = @_;
+
+ if ( $ENV{CATALYST_HOME} ) {
+ $home = $ENV{CATALYST_HOME};
+ }
+
+ if ( $ENV{ uc($class) . '_HOME' } ) {
+ $home = $ENV{ uc($class) . '_HOME' };
+ }
+
+ unless ($home) {
+ $home = Catalyst::Utils::home($class);
+ }
+
+ if ($home) {
+ $class->config->{home} ||= $home;
+ $class->config->{root} ||= dir($home)->subdir('root');
+ }
+}
+
+=item $c->setup_log
+
+=cut
+
+sub setup_log {
+ my ( $class, $debug ) = @_;
+
+ unless ( $class->log ) {
+ $class->log( Catalyst::Log->new );
+ }
+
+ if ( $ENV{CATALYST_DEBUG} || $ENV{ uc($class) . '_DEBUG' } || $debug ) {
+ no strict 'refs';
+ *{"$class\::debug"} = sub { 1 };
+ $class->log->debug('Debug messages enabled');
+ }
+}
+
+=item $c->setup_plugins
+
+=cut
+
+sub setup_plugins {
+ my ( $class, $plugins ) = @_;
+
+ $plugins ||= [];
+ for my $plugin ( reverse @$plugins ) {
+
+ $plugin = "Catalyst::Plugin::$plugin";
+
+ $plugin->require;
+
+ if ($@) {
+ Catalyst::Exception->throw(
+ message => qq/Couldn't load plugin "$plugin", "$@"/ );
+ }
+
+ {
+ no strict 'refs';
+ unshift @{"$class\::ISA"}, $plugin;
+ }
+ }
+}
+
+=item $c->write( $data )
+
+Writes $data to the output stream. When using this method directly, you will
+need to manually set the Content-Length header to the length of your output
+data, if known.
+
+=cut
+
+sub write { my $c = shift; return $c->engine->write( $c, @_ ) }
+
=back
=head1 CASE SENSITIVITY
MyApp->config->{case_sensitive} = 1;
-=head1 LIMITATIONS
+So C<MyApp::C::Foo::Bar> becomes C</Foo/Bar>.
+
+=head1 ON-DEMAND PARSER
+
+The request body is usually parsed at the beginning of a request,
+but if you want to handle input yourself or speed things up a bit
+you can enable on-demand parsing with a config parameter.
+
+ MyApp->config->{parse_on_demand} = 1;
+
+=head1 PROXY SUPPORT
+
+Many production servers operate using the common double-server approach, with
+a lightweight frontend web server passing requests to a larger backend
+server. An application running on the backend server must deal with two
+problems: the remote user always appears to be '127.0.0.1' and the server's
+hostname will appear to be 'localhost' regardless of the virtual host the
+user connected through.
+
+Catalyst will automatically detect this situation when you are running both
+the frontend and backend servers on the same machine. The following changes
+are made to the request.
+
+ $c->req->address is set to the user's real IP address, as read from the
+ HTTP_X_FORWARDED_FOR header.
+
+ The host value for $c->req->base and $c->req->uri is set to the real host,
+ as read from the HTTP_X_FORWARDED_HOST header.
+
+Obviously, your web server must support these 2 headers for this to work.
+
+In a more complex server farm environment where you may have your frontend
+proxy server(s) on different machines, you will need to set a configuration
+option to tell Catalyst to read the proxied data from the headers.
+
+ MyApp->config->{using_frontend_proxy} = 1;
+
+If you do not wish to use the proxy support at all, you may set:
-mod_perl2 support is considered experimental and may contain bugs.
+ MyApp->config->{ignore_frontend_proxy} = 1;
+
+=head1 THREAD SAFETY
+
+Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
+and the standalone forking HTTP server on Windows. We believe the Catalyst
+core to be thread-safe.
+
+If you plan to operate in a threaded environment, remember that all other
+modules you are using must also be thread-safe. Some modules, most notably
+DBD::SQLite, are not thread-safe.
=head1 SUPPORT
Andy Grundman
+Andy Wardley
+
Andrew Ford
Andrew Ruthven
+Arthur Bergman
+
Autrijus Tang
Christian Hansen
Jesse Sheidlower
+Jesse Vincent
+
Jody Belka
Johan Lindstrom
Robert Sedlacek
-Sebastian Riedel
-
Tatsuhiko Miyagawa
Ulf Edvinsson
--- /dev/null
+package Catalyst::Action;
+
+use strict;
+use base qw/Class::Accessor::Fast/;
+
+__PACKAGE__->mk_accessors(qw/code namespace reverse/);
+
+use overload (
+
+ # Stringify to reverse for debug output etc.
+ q{""} => sub { shift->{reverse} },
+
+ # Codulate to encapsulated action coderef
+ '&{}' => sub { shift->{code} },
+
+);
+
+=head1 NAME
+
+Catalyst::Action - Catalyst Action
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item code
+
+=item execute
+
+=cut
+
+sub execute { # Execute ourselves against a context
+ my ( $self, $c ) = @_;
+ return $c->execute( $self->namespace, $self );
+}
+
+=item namespace
+
+=item reverse
+
+=item new
+
+=cut
+
+sub new { # Dumbass constructor
+ my ( $class, $attrs ) = @_;
+ return bless { %{ $attrs || {} } }, $class;
+}
+
+=back
+
+=head1 AUTHOR
+
+Matt S. Trout
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
package Catalyst::Dispatcher;
use strict;
-use base 'Class::Data::Inheritable';
+use base 'Class::Accessor::Fast';
use Catalyst::Exception;
use Catalyst::Utils;
+use Catalyst::Action;
use Text::ASCIITable;
use Tree::Simple;
use Tree::Simple::Visitor::FindByPath;
-__PACKAGE__->mk_classdata($_) for qw/actions tree/;
+# Stringify to class
+use overload '""' => sub { return ref shift }, fallback => 1;
+
+__PACKAGE__->mk_accessors(qw/actions tree/);
=head1 NAME
=over 4
-=item $c->detach( $command [, \@arguments ] )
-
-Like C<forward> but doesn't return.
+=item $self->detach( $c, $command [, \@arguments ] )
=cut
sub detach {
- my ( $c, $command, @args ) = @_;
+ my ( $self, $c, $command, @args ) = @_;
$c->forward( $command, @args ) if $command;
- # die with DETACH signal, which will be caught in dispatching.
- die $Catalyst::Engine::DETACH;
+ die $Catalyst::DETACH;
}
-=item $c->dispatch
-
-Dispatch request to actions.
+=item $self->dispatch($c)
=cut
sub dispatch {
- my $c = shift;
+ my ( $self, $c ) = @_;
my $action = $c->req->action;
my $namespace = '';
$namespace = ( join( '/', @{ $c->req->args } ) || '/' )
unless ($namespace) {
if ( my $result = $c->get_action($action) ) {
- $namespace = Catalyst::Utils::class2prefix( $result->[0]->[0]->[0],
+ $namespace =
+ Catalyst::Utils::class2prefix( $result->[0]->[0]->namespace,
$c->config->{case_sensitive} );
}
}
if ( @{$results} ) {
+ # Errors break the normal flow and the end action is instantly run
+ my $error = 0;
+
# Execute last begin
$c->state(1);
if ( my $begin = @{ $c->get_action( 'begin', $namespace, 1 ) }[-1] ) {
- $c->execute( @{ $begin->[0] } );
- return if scalar @{ $c->error };
+ $begin->[0]->execute($c);
+ $error++ if scalar @{ $c->error };
}
# Execute the auto chain
my $autorun = 0;
for my $auto ( @{ $c->get_action( 'auto', $namespace, 1 ) } ) {
+ last if $error;
$autorun++;
- $c->execute( @{ $auto->[0] } );
- return if scalar @{ $c->error };
+ $auto->[0]->execute($c);
+ $error++ if scalar @{ $c->error };
last unless $c->state;
}
# Execute the action or last default
my $mkay = $autorun ? $c->state ? 1 : 0 : 1;
if ( ( my $action = $c->req->action ) && $mkay ) {
- if ( my $result = @{ $c->get_action( $action, $default, 1 ) }[-1] )
- {
- $c->execute( @{ $result->[0] } );
+ unless ($error) {
+ if ( my $result =
+ @{ $c->get_action( $action, $default, 1 ) }[-1] )
+ {
+ $result->[0]->execute($c);
+ $error++ if scalar @{ $c->error };
+ }
}
}
# Execute last end
if ( my $end = @{ $c->get_action( 'end', $namespace, 1 ) }[-1] ) {
- $c->execute( @{ $end->[0] } );
- return if scalar @{ $c->error };
+ $end->[0]->execute($c);
}
- } else {
+ }
+
+ else {
my $path = $c->req->path;
my $error = $path
? qq/Unknown resource "$path"/
}
}
-=item $c->forward( $command [, \@arguments ] )
-
-Forward processing to a private action or a method from a class.
-If you define a class without method it will default to process().
-also takes an optional arrayref containing arguments to be passed
-to the new function. $c->req->args will be reset upon returning
-from the function.
-
- $c->forward('/foo');
- $c->forward('index');
- $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
- $c->forward('MyApp::View::TT');
+=item $self->forward( $c, $command [, \@arguments ] )
=cut
sub forward {
+ my $self = shift;
my $c = shift;
my $command = shift;
}
# Relative forwards from detach
- my $caller = ( caller(0) )[0]->isa('Catalyst::Dispatcher')
- && ( ( caller(1) )[3] =~ /::detach$/ ) ? caller(1) : caller(0);
+ my $caller = ( caller(1) )[0]->isa('Catalyst::Dispatcher')
+ && ( ( caller(2) )[3] =~ /::detach$/ ) ? caller(3) : caller(1);
my $namespace = '/';
my $arguments = ( ref( $_[-1] ) eq 'ARRAY' ) ? pop(@_) : $c->req->args;
+ my $results = [];
+
if ( $command =~ /^\// ) {
- $command =~ /^\/(.*)\/(\w+)$/;
- $namespace = $1 || '/';
- $command = $2 || $command;
+ if ( $command =~ /^\/(\w+)$/ ) {
+ $results = $c->get_action( $1, $namespace );
+ }
+ else {
+ my $command_copy = $command;
+ my @extra_args;
+ DESCEND: while ( $command_copy =~ s/^\/(.*)\/(\w+)$/\/$1/ ) {
+ my $tail = $2;
+ if ( $results = $c->get_action( $tail, $1 ) ) {
+ $command = $tail;
+ $namespace = $command_copy;
+ push( @{$arguments}, @extra_args );
+ last DESCEND;
+ }
+ unshift( @extra_args, $tail );
+ }
+ }
$command =~ s/^\///;
}
$namespace =
Catalyst::Utils::class2prefix( $caller, $c->config->{case_sensitive} )
|| '/';
+ $results = $c->get_action( $command, $namespace );
}
- my $results = $c->get_action( $command, $namespace );
-
unless ( @{$results} ) {
- unless ( defined( $c->components->{$command} ) ) {
+ unless ( $c->components->{$command} ) {
my $error =
qq/Couldn't forward to command "$command". Invalid action or component./;
$c->error($error);
my $method = shift || 'process';
if ( my $code = $c->components->{$class}->can($method) ) {
- $c->actions->{reverse}->{"$code"} = "$class->$method";
- $results = [ [ [ $class, $code ] ] ];
- } else {
+ my $action = Catalyst::Action->new(
+ {
+ code => $code,
+ reverse => "$class->$method",
+ namespace => $class,
+ }
+ );
+ $results = [ [$action] ];
+ }
+
+ else {
my $error =
qq/Couldn't forward to "$class". Does not implement "$method"/;
$c->error($error);
local $c->request->{arguments} = [ @{$arguments} ];
for my $result ( @{$results} ) {
- $c->execute( @{ $result->[0] } );
+ $result->[0]->execute($c);
return if scalar @{ $c->error };
last unless $c->state;
}
return $c->state;
}
-=item $c->get_action( $action, $namespace, $inherit )
+=item $self->prepare_action($c)
+
+=cut
+
+sub prepare_action {
+ my ( $self, $c ) = @_;
+ my $path = $c->req->path;
+ my @path = split /\//, $c->req->path;
+ $c->req->args( \my @args );
+
+ while (@path) {
+ $path = join '/', @path;
+ if ( my $result = ${ $c->get_action($path) }[0] ) {
+
+ # It's a regex
+ if ($#$result) {
+ my $match = $result->[1];
+ my @snippets = @{ $result->[2] };
+ $c->log->debug(
+ qq/Requested action is "$path" and matched "$match"/)
+ if $c->debug;
+ $c->log->debug(
+ 'Snippets are "' . join( ' ', @snippets ) . '"' )
+ if ( $c->debug && @snippets );
+ $c->req->action($match);
+ $c->req->snippets( \@snippets );
+ }
+
+ else {
+ $c->req->action($path);
+ $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
+ }
-Get an action in a given namespace.
+ $c->req->match($path);
+ last;
+ }
+ unshift @args, pop @path;
+ }
+
+ unless ( $c->req->action ) {
+ $c->req->action('default');
+ $c->req->match('');
+ }
+
+ $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
+ if ( $c->debug && @args );
+}
+
+=item $self->get_action( $c, $action, $namespace, $inherit )
=cut
sub get_action {
- my ( $c, $action, $namespace, $inherit ) = @_;
+ my ( $self, $c, $action, $namespace, $inherit ) = @_;
return [] unless $action;
$namespace ||= '';
$inherit ||= 0;
if ($namespace) {
$namespace = '' if $namespace eq '/';
- my $parent = $c->tree;
+ my $parent = $self->tree;
my @results;
if ($inherit) {
- my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
+ my $result =
+ $self->actions->{private}->{ $parent->getUID }->{$action};
push @results, [$result] if $result;
my $visitor = Tree::Simple::Visitor::FindByPath->new;
- SEARCH:
+ SEARCH:
for my $part ( split '/', $namespace ) {
$visitor->setSearchPath($part);
$parent->accept($visitor);
my $child = $visitor->getResult;
my $uid = $child->getUID if $child;
- my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
+ my $match = $self->actions->{private}->{$uid}->{$action}
+ if $uid;
push @results, [$match] if $match;
if ($child) {
$parent = $child;
$parent->accept($visitor);
my $child = $visitor->getResult;
my $uid = $child->getUID if $child;
- my $match = $c->actions->{private}->{$uid}->{$action}
+ my $match = $self->actions->{private}->{$uid}->{$action}
if $uid;
push @results, [$match] if $match;
}
else {
my $result =
- $c->actions->{private}->{ $parent->getUID }->{$action};
+ $self->actions->{private}->{ $parent->getUID }->{$action};
push @results, [$result] if $result;
}
return \@results;
}
- elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
- elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
+ elsif ( my $p = $self->actions->{plain}->{$action} ) { return [ [$p] ] }
+ elsif ( my $r = $self->actions->{regex}->{$action} ) { return [ [$r] ] }
else {
- for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
- my $name = $c->actions->{compiled}->[$i]->[0];
- my $regex = $c->actions->{compiled}->[$i]->[1];
+ for my $i ( 0 .. $#{ $self->actions->{compiled} } ) {
+ my $name = $self->actions->{compiled}->[$i]->[0];
+ my $regex = $self->actions->{compiled}->[$i]->[1];
if ( my @snippets = ( $action =~ $regex ) ) {
- return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
+ return [
+ [ $self->actions->{regex}->{$name}, $name, \@snippets ] ];
}
}
return [];
}
-=item $c->set_action( $action, $code, $namespace, $attrs )
-
-Set an action in a given namespace.
+=item $self->set_action( $c, $action, $code, $namespace, $attrs )
=cut
sub set_action {
- my ( $c, $method, $code, $namespace, $attrs ) = @_;
+ my ( $self, $c, $method, $code, $namespace, $attrs ) = @_;
my $prefix =
Catalyst::Utils::class2prefix( $namespace, $c->config->{case_sensitive} )
}
return unless keys %flags;
- my $parent = $c->tree;
+ my $parent = $self->tree;
my $visitor = Tree::Simple::Visitor::FindByPath->new;
for my $part ( split '/', $prefix ) {
$parent = $child;
}
- my $uid = $parent->getUID;
- $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
my $forward = $prefix ? "$prefix/$method" : $method;
+ my $reverse = $prefix ? "$prefix/$method" : $method;
+
+ my $action = Catalyst::Action->new(
+ {
+ code => $code,
+ reverse => $reverse,
+ namespace => $namespace,
+ }
+ );
+
+ my $uid = $parent->getUID;
+ $self->actions->{private}->{$uid}->{$method} = $action;
+
if ( $flags{path} ) {
$flags{path} =~ s/^\w+//;
$flags{path} =~ s/\w+$//;
if ( $flags{regex} =~ /^\s*"(.*)"\s*$/ ) { $flags{regex} = $1 }
}
- my $reverse = $prefix ? "$prefix/$method" : $method;
-
if ( $flags{local} || $flags{global} || $flags{path} ) {
my $path = $flags{path} || $method;
my $absolute = 0;
$absolute = 1 if $flags{global};
my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
- $c->actions->{plain}->{$name} = [ $namespace, $code ];
+ $self->actions->{plain}->{$name} = $action;
}
if ( my $regex = $flags{regex} ) {
- push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
- $c->actions->{regex}->{$regex} = [ $namespace, $code ];
+ push @{ $self->actions->{compiled} }, [ $regex, qr#$regex# ];
+ $self->actions->{regex}->{$regex} = $action;
}
-
- $c->actions->{reverse}->{"$code"} = $reverse;
}
-=item $class->setup_actions($component)
-
-Setup actions for a component.
+=item $self->setup_actions( $class, $component )
=cut
sub setup_actions {
- my $self = shift;
+ my ( $self, $class ) = @_;
# These are the core structures
$self->actions(
plain => {},
private => {},
regex => {},
- compiled => [],
- reverse => {}
+ compiled => []
}
);
# We use a tree
$self->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
- for my $comp ( keys %{ $self->components } ) {
+ for my $comp ( keys %{ $class->components } ) {
# We only setup components that inherit from Catalyst::Base
next unless $comp->isa('Catalyst::Base');
if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
$name = *{$sym}{NAME};
- $self->set_action( $name, $code, $comp, $attrs );
+ $class->set_action( $name, $code, $comp, $attrs );
last;
}
}
- return unless $self->debug;
+ return unless $class->debug;
my $actions = $self->actions;
my $privates = Text::ASCIITable->new;
my $uid = $parent->getUID;
for my $action ( keys %{ $actions->{private}->{$uid} } ) {
- my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
- $privates->addRow( "$prefix$action", $class );
+ my $action_obj = $actions->{private}->{$uid}->{$action};
+ $privates->addRow( "$prefix$action", $action_obj->namespace );
}
$walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
};
$walker->( $walker, $self->tree, '' );
- $self->log->debug( "Loaded private actions:\n" . $privates->draw )
+ $class->log->debug( "Loaded private actions:\n" . $privates->draw )
if ( @{ $privates->{tbl_rows} } );
my $publics = Text::ASCIITable->new;
$publics->setColWidth( 'Private', 37, 1 );
for my $plain ( sort keys %{ $actions->{plain} } ) {
- my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
- my $reverse = $self->actions->{reverse}->{$code};
- $reverse = $reverse ? "/$reverse" : $code;
- $publics->addRow( "/$plain", $reverse );
+ my $action = $actions->{plain}->{$plain};
+ $publics->addRow( "/$plain", "/$action" );
}
- $self->log->debug( "Loaded public actions:\n" . $publics->draw )
+ $class->log->debug( "Loaded public actions:\n" . $publics->draw )
if ( @{ $publics->{tbl_rows} } );
my $regexes = Text::ASCIITable->new;
$regexes->setColWidth( 'Private', 37, 1 );
for my $regex ( sort keys %{ $actions->{regex} } ) {
- my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
- my $reverse = $self->actions->{reverse}->{$code};
- $reverse = $reverse ? "/$reverse" : $code;
- $regexes->addRow( $regex, $reverse );
+ my $action = $actions->{regex}->{$regex};
+ $regexes->addRow( $regex, "/$action" );
}
- $self->log->debug( "Loaded regex actions:\n" . $regexes->draw )
+ $class->log->debug( "Loaded regex actions:\n" . $regexes->draw )
if ( @{ $regexes->{tbl_rows} } );
}
package Catalyst::Engine;
use strict;
-use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
-use attributes ();
-use UNIVERSAL::require;
+use base 'Class::Accessor::Fast';
use CGI::Cookie;
use Data::Dumper;
use HTML::Entities;
+use HTTP::Body;
use HTTP::Headers;
-use Time::HiRes qw/gettimeofday tv_interval/;
-use Text::ASCIITable;
-use Catalyst::Exception;
-use Catalyst::Request;
-use Catalyst::Request::Upload;
-use Catalyst::Response;
-use Catalyst::Utils;
-
-__PACKAGE__->mk_classdata('components');
-__PACKAGE__->mk_accessors(qw/counter depth request response state/);
-
-*comp = \&component;
-*req = \&request;
-*res = \&response;
-
-# For backwards compatibility
-*finalize_output = \&finalize_body;
-
-# For statistics
-our $COUNT = 1;
-our $START = time;
-our $RECURSION = 1000;
-our $DETACH = "catalyst_detach\n";
+
+# input position and length
+__PACKAGE__->mk_accessors( qw/read_position read_length/ );
+
+# Stringify to class
+use overload '""' => sub { return ref shift }, fallback => 1;
=head1 NAME
=over 4
-=item $c->benchmark($coderef)
-
-Takes a coderef with arguments and returns elapsed time as float.
-
- my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
- $c->log->info( sprintf "Processing took %f seconds", $elapsed );
-
-=cut
-
-sub benchmark {
- my $c = shift;
- my $code = shift;
- my $time = [gettimeofday];
- my @return = &$code(@_);
- my $elapsed = tv_interval $time;
- return wantarray ? ( $elapsed, @return ) : $elapsed;
-}
-
-=item $c->comp($name)
-
-=item $c->component($name)
-
-Get a component object by name.
-
- $c->comp('MyApp::Model::MyModel')->do_stuff;
-
-Regex search for a component.
-
- $c->comp('mymodel')->do_stuff;
-
-=cut
-
-sub component {
- my $c = shift;
-
- if (@_) {
-
- my $name = shift;
-
- if ( my $component = $c->components->{$name} ) {
- return $component;
- }
-
- else {
- for my $component ( keys %{ $c->components } ) {
- return $c->components->{$component} if $component =~ /$name/i;
- }
- }
- }
-
- return sort keys %{ $c->components };
-}
-
-=item $c->counter
-
-Returns a hashref containing coderefs and execution counts.
-(Needed for deep recursion detection)
-
-=item $c->depth
-
-Returns the actual forward depth.
-
-=item $c->error
-
-=item $c->error($error, ...)
-
-=item $c->error($arrayref)
-
-Returns an arrayref containing error messages.
-
- my @error = @{ $c->error };
-
-Add a new error.
-
- $c->error('Something bad happened');
-
-=cut
-
-sub error {
- my $c = shift;
- my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
- push @{ $c->{error} }, @$error;
- return $c->{error};
-}
-
-=item $c->execute($class, $coderef)
-
-Execute a coderef in given class and catch exceptions.
-Errors are available via $c->error.
-
-=cut
-
-sub execute {
- my ( $c, $class, $code ) = @_;
- $class = $c->components->{$class} || $class;
- $c->state(0);
- my $callsub = ( caller(1) )[3];
-
- my $action = '';
- if ( $c->debug ) {
- $action = $c->actions->{reverse}->{"$code"};
- $action = "/$action" unless $action =~ /\-\>/;
- $c->counter->{"$code"}++;
-
- if ( $c->counter->{"$code"} > $RECURSION ) {
- my $error = qq/Deep recursion detected in "$action"/;
- $c->log->error($error);
- $c->error($error);
- $c->state(0);
- return $c->state;
- }
-
- $action = "-> $action" if $callsub =~ /forward$/;
- }
-
- $c->{depth}++;
- eval {
- if ( $c->debug )
- {
- my ( $elapsed, @state ) =
- $c->benchmark( $code, $class, $c, @{ $c->req->args } );
- push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
- $c->state(@state);
- }
- else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
- };
- $c->{depth}--;
-
- if ( my $error = $@ ) {
-
- if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
- else {
- unless ( ref $error ) {
- chomp $error;
- $error = qq/Caught exception "$error"/;
- }
-
- $c->log->error($error);
- $c->error($error);
- $c->state(0);
- }
- }
- return $c->state;
-}
-
-=item $c->finalize
-
-Finalize request.
-
-=cut
-
-sub finalize {
- my $c = shift;
-
- $c->finalize_cookies;
-
- if ( my $location = $c->response->redirect ) {
- $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
- $c->response->header( Location => $location );
- $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
- }
-
- if ( $#{ $c->error } >= 0 ) {
- $c->finalize_error;
- }
-
- if ( !$c->response->body && $c->response->status == 200 ) {
- $c->finalize_error;
- }
-
- if ( $c->response->body && !$c->response->content_length ) {
- $c->response->content_length( bytes::length( $c->response->body ) );
- }
-
- if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
- $c->response->headers->remove_header("Content-Length");
- $c->response->body('');
- }
-
- if ( $c->request->method eq 'HEAD' ) {
- $c->response->body('');
- }
-
- my $status = $c->finalize_headers;
- $c->finalize_body;
- return $status;
-}
-
-=item $c->finalize_output
+=item $self->finalize_output
<obsolete>, see finalize_body
-=item $c->finalize_body
+=item $self->finalize_body($c)
-Finalize body.
+Finalize body. Prints the response output.
=cut
-sub finalize_body { }
-
-=item $c->finalize_cookies
+sub finalize_body {
+ my ( $self, $c ) = @_;
+
+ $self->write( $c, $c->response->output );
+}
-Finalize cookies.
+=item $self->finalize_cookies($c)
=cut
sub finalize_cookies {
- my $c = shift;
+ my ( $self, $c ) = @_;
+ my @cookies;
while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
+
my $cookie = CGI::Cookie->new(
-name => $name,
-value => $cookie->{value},
-secure => $cookie->{secure} || 0
);
- $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
+ push @cookies, $cookie->as_string;
}
-}
-=item $c->finalize_error
+ if (@cookies) {
+ $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies );
+ }
+}
-Finalize error.
+=item $self->finalize_error($c)
=cut
sub finalize_error {
- my $c = shift;
+ my ( $self, $c ) = @_;
$c->res->headers->content_type('text/html');
my $name = $c->config->{name} || 'Catalyst Application';
@{ $c->error };
$error ||= 'No output';
$title = $name = "$name on Catalyst $Catalyst::VERSION";
+
+ # Don't show context in the dump
+ delete $c->req->{_context};
+ delete $c->res->{_context};
+
+ # Don't show body parser in the dump
+ delete $c->req->{_body};
+
+ # Don't show response header state in dump
+ delete $c->res->{_finalized_headers};
+
my $req = encode_entities Dumper $c->req;
my $res = encode_entities Dumper $c->res;
my $stash = encode_entities Dumper $c->stash;
(fr) Veuillez revenir plus tard
(es) Vuelto por favor mas adelante
(pt) Voltado por favor mais tarde
-(it) Ritornato prego più successivamente
+(it) Ritornato prego più successivamente
</pre>
$name = '';
}
-=item $c->finalize_headers
-
-Finalize headers.
+=item $self->finalize_headers($c)
=cut
sub finalize_headers { }
-=item $c->handler( $class, @arguments )
-
-Handles the request.
+=item $self->finalize_read($c)
=cut
-sub handler {
- my ( $class, @arguments ) = @_;
-
- # Always expect worst case!
- my $status = -1;
- eval {
- my @stats = ();
-
- my $handler = sub {
- my $c = $class->prepare(@arguments);
- $c->{stats} = \@stats;
- $c->dispatch;
- return $c->finalize;
- };
-
- if ( $class->debug ) {
- my $elapsed;
- ( $elapsed, $status ) = $class->benchmark($handler);
- $elapsed = sprintf '%f', $elapsed;
- my $av = sprintf '%.3f',
- ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
- my $t = Text::ASCIITable->new;
- $t->setCols( 'Action', 'Time' );
- $t->setColWidth( 'Action', 64, 1 );
- $t->setColWidth( 'Time', 9, 1 );
-
- for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
- $class->log->info(
- "Request took ${elapsed}s ($av/s)\n" . $t->draw );
- }
- else { $status = &$handler }
-
- };
-
- if ( my $error = $@ ) {
- chomp $error;
- $class->log->error(qq/Caught exception in engine "$error"/);
- }
-
- $COUNT++;
- return $status;
+sub finalize_read {
+ my ( $self, $c ) = @_;
+
+ undef $self->{_prepared_read};
}
-=item $c->prepare(@arguments)
-
-Turns the engine-specific request( Apache, CGI ... )
-into a Catalyst context .
+=item $self->finalize_uploads($c)
=cut
-sub prepare {
- my ( $class, @arguments ) = @_;
-
- my $c = bless {
- counter => {},
- depth => 0,
- request => Catalyst::Request->new(
- {
- arguments => [],
- cookies => {},
- headers => HTTP::Headers->new,
- parameters => {},
- secure => 0,
- snippets => [],
- uploads => {}
- }
- ),
- response => Catalyst::Response->new(
- {
- body => '',
- cookies => {},
- headers => HTTP::Headers->new( 'Content-Length' => 0 ),
- status => 200
- }
- ),
- stash => {},
- state => 0
- }, $class;
+sub finalize_uploads {
+ my ( $self, $c ) = @_;
- if ( $c->debug ) {
- my $secs = time - $START || 1;
- my $av = sprintf '%.3f', $COUNT / $secs;
- $c->log->debug('**********************************');
- $c->log->debug("* Request $COUNT ($av/s) [$$]");
- $c->log->debug('**********************************');
- $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
- }
-
- $c->prepare_request(@arguments);
- $c->prepare_connection;
- $c->prepare_headers;
- $c->prepare_cookies;
- $c->prepare_path;
- $c->prepare_action;
-
- my $method = $c->req->method || '';
- my $path = $c->req->path || '';
- my $address = $c->req->address || '';
-
- $c->log->debug(qq/"$method" request for "$path" from $address/)
- if $c->debug;
-
- if ( $c->request->method eq 'POST' and $c->request->content_length ) {
-
- if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
- $c->prepare_parameters;
- }
- elsif ( $c->req->content_type eq 'multipart/form-data' ) {
- $c->prepare_parameters;
- $c->prepare_uploads;
- }
- else {
- $c->prepare_body;
- }
- }
-
- if ( $c->request->method eq 'GET' ) {
- $c->prepare_parameters;
- }
-
- if ( $c->debug && keys %{ $c->req->params } ) {
- my $t = Text::ASCIITable->new;
- $t->setCols( 'Key', 'Value' );
- $t->setColWidth( 'Key', 37, 1 );
- $t->setColWidth( 'Value', 36, 1 );
- for my $key ( sort keys %{ $c->req->params } ) {
- my $param = $c->req->params->{$key};
- my $value = defined($param) ? $param : '';
- $t->addRow( $key, $value );
+ if ( keys %{ $c->request->uploads } ) {
+ for my $key ( keys %{ $c->request->uploads } ) {
+ my $upload = $c->request->uploads->{$key};
+ unlink map { $_->tempname }
+ grep { -e $_->tempname }
+ ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
}
- $c->log->debug( "Parameters are:\n" . $t->draw );
}
-
- return $c;
}
-=item $c->prepare_action
-
-Prepare action.
+=item $self->prepare_body($c)
=cut
-sub prepare_action {
- my $c = shift;
- my $path = $c->req->path;
- my @path = split /\//, $c->req->path;
- $c->req->args( \my @args );
-
- while (@path) {
- $path = join '/', @path;
- if ( my $result = ${ $c->get_action($path) }[0] ) {
-
- # It's a regex
- if ($#$result) {
- my $match = $result->[1];
- my @snippets = @{ $result->[2] };
- $c->log->debug(
- qq/Requested action is "$path" and matched "$match"/)
- if $c->debug;
- $c->log->debug(
- 'Snippets are "' . join( ' ', @snippets ) . '"' )
- if ( $c->debug && @snippets );
- $c->req->action($match);
- $c->req->snippets( \@snippets );
- }
+sub prepare_body {
+ my ( $self, $c ) = @_;
- else {
- $c->req->action($path);
- $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
- }
+ $self->read_length( $c->request->header('Content-Length') || 0 );
+ my $type = $c->request->header('Content-Type');
- $c->req->match($path);
- last;
- }
- unshift @args, pop @path;
+ unless ( $c->request->{_body} ) {
+ $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
}
-
- unless ( $c->req->action ) {
- $c->req->action('default');
- $c->req->match('');
+
+ if ( $self->read_length > 0 ) {
+ while ( my $buffer = $self->read( $c ) ) {
+ $c->request->{_body}->add( $buffer );
+ }
}
-
- $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
- if ( $c->debug && @args );
}
-=item $c->prepare_body
-
-Prepare message body.
+=item $self->prepare_body_parameters($c)
=cut
-sub prepare_body { }
-
-=item $c->prepare_connection
+sub prepare_body_parameters {
+ my ( $self, $c ) = @_;
+ $c->request->body_parameters( $c->request->{_body}->param );
+}
-Prepare connection.
+=item $self->prepare_connection($c)
=cut
sub prepare_connection { }
-=item $c->prepare_cookies
-
-Prepare cookies.
+=item $self->prepare_cookies($c)
=cut
sub prepare_cookies {
- my $c = shift;
+ my ( $self, $c ) = @_;
if ( my $header = $c->request->header('Cookie') ) {
$c->req->cookies( { CGI::Cookie->parse($header) } );
}
}
-=item $c->prepare_headers
-
-Prepare headers.
+=item $self->prepare_headers($c)
=cut
sub prepare_headers { }
-=item $c->prepare_parameters
-
-Prepare parameters.
+=item $self->prepare_parameters($c)
=cut
-sub prepare_parameters { }
+sub prepare_parameters {
+ my ( $self, $c ) = @_;
-=item $c->prepare_path
+ # We copy, no references
+ while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
+ $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
+ $c->request->parameters->{$name} = $param;
+ }
-Prepare path and base.
+ # Merge query and body parameters
+ while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
+ $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
+ if ( my $old_param = $c->request->parameters->{$name} ) {
+ if ( ref $old_param eq 'ARRAY' ) {
+ push @{ $c->request->parameters->{$name} },
+ ref $param eq 'ARRAY' ? @$param : $param;
+ }
+ else { $c->request->parameters->{$name} = [ $old_param, $param ] }
+ }
+ else { $c->request->parameters->{$name} = $param }
+ }
+}
+
+=item $self->prepare_path($c)
=cut
sub prepare_path { }
-=item $c->prepare_request
+=item $self->prepare_request($c)
-Prepare the engine request.
+=item $self->prepare_query_parameters($c)
=cut
-sub prepare_request { }
+sub prepare_query_parameters { }
+
+=item $self->prepare_read($c)
+
+=cut
-=item $c->prepare_uploads
+sub prepare_read {
+ my ( $self, $c ) = @_;
+
+ # Reset the read position
+ $self->read_position( 0 );
+}
-Prepare uploads.
+=item $self->prepare_request(@arguments)
=cut
-sub prepare_uploads { }
+sub prepare_request { }
-=item $c->run
+=item $self->prepare_uploads($c)
-Starts the engine.
+=cut
+
+sub prepare_uploads {
+ my ( $self, $c ) = @_;
+ my $uploads = $c->request->{_body}->upload;
+ for my $name ( keys %$uploads ) {
+ my $files = $uploads->{$name};
+ $files = ref $files eq 'ARRAY' ? $files : [$files];
+ my @uploads;
+ for my $upload (@$files) {
+ my $u = Catalyst::Request::Upload->new;
+ $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
+ $u->type( $u->headers->content_type );
+ $u->tempname( $upload->{tempname} );
+ $u->size( $upload->{size} );
+ $u->filename( $upload->{filename} );
+ push @uploads, $u;
+ }
+ $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
+ }
+}
+
+=item $self->prepare_write($c)
=cut
-sub run { }
+sub prepare_write { }
+
+=item $self->read($c, [$maxlength])
+
+=cut
+
+sub read {
+ my ( $self, $c, $maxlength ) = @_;
+
+ unless ( $self->{_prepared_read} ) {
+ $self->prepare_read( $c );
+ $self->{_prepared_read} = 1;
+ }
+
+ my $remaining = $self->read_length - $self->read_position;
+ $maxlength ||= $self->read_length;
+
+ # Are we done reading?
+ if ( $remaining <= 0 ) {
+ $self->finalize_read( $c );
+ return;
+ }
-=item $c->request
+ my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
+ my $rc = $self->read_chunk( $c, my $buffer, $readlen );
+ if ( defined $rc ) {
+ $self->read_position( $self->read_position + $rc );
+ return $buffer;
+ }
+ else {
+ Catalyst::Exception->throw(
+ message => "Unknown error reading input: $!"
+ );
+ }
+}
-=item $c->req
+=item $self->read_chunk($c, $buffer, $length)
-Returns a C<Catalyst::Request> object.
+Each engine inplements read_chunk as its preferred way of reading a chunk
+of data.
- my $req = $c->req;
+=cut
-=item $c->response
+sub read_chunk { }
-=item $c->res
+=item $self->read_length
-Returns a C<Catalyst::Response> object.
+The length of input data to be read. This is obtained from the Content-Length
+header.
- my $res = $c->res;
+=item $self->read_position
-=item $c->state
+The amount of input data that has already been read.
-Contains the return value of the last executed action.
+=item $self->run($c)
-=item $c->stash
+=cut
-Returns a hashref containing all your data.
+sub run { }
- $c->stash->{foo} ||= 'yada';
- print $c->stash->{foo};
+=item $self->write($c, $buffer)
=cut
-sub stash {
- my $self = shift;
- if (@_) {
- my $stash = @_ > 1 ? {@_} : $_[0];
- while ( my ( $key, $val ) = each %$stash ) {
- $self->{stash}->{$key} = $val;
- }
+sub write {
+ my ( $self, $c, $buffer ) = @_;
+
+ unless ( $self->{_prepared_write} ) {
+ $self->prepare_write( $c );
+ $self->{_prepared_write} = 1;
}
- return $self->{stash};
+
+ my $handle = $c->response->handle;
+
+ print $handle $buffer;
}
=back
-=head1 AUTHOR
+=head1 AUTHORS
+
+Sebastian Riedel, <sri@cpan.org>
-Sebastian Riedel, C<sri@cpan.org>
+Andy Grundman, <andy@hybridized.org>
=head1 COPYRIGHT
+++ /dev/null
-package Catalyst::Engine::Apache;
-
-use strict;
-
-# 1.27 MP13
-# 1.28 MP13
-# 1.29 MP13
-# 1.2901 MP13
-# 1.30 MP13 TBR
-
-# 1.9901 MP19
-# 1.9920 MP19
-# 1.999020 MP19 RC3
-# 1.999021 MP19 RC4
-
-# 1.999022 MP20 RC5
-# 1.999023 MP20 RC6
-
-1;
-
-__END__
-
-=head1 NAME
-
-Catalyst::Engine::Apache - Catalyst Apache Engine
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This class will load the correct MP Engine.
-
-=head1 SEE ALSO
-
-L<Catalyst>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package Catalyst::Engine::Apache::Base;
-
-use strict;
-use base qw[Catalyst::Engine Catalyst::Engine::Apache];
-
-use File::Spec;
-use URI;
-use URI::http;
-
-__PACKAGE__->mk_accessors(qw/apache/);
-
-=head1 NAME
-
-Catalyst::Engine::Apache::Base - Base class for Apache Engines
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is a base class for Apache Engines.
-
-=head1 METHODS
-
-=over 4
-
-=item $c->apache
-
-Returns an C<Apache::Request> object.
-
-=back
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine>.
-
-=over 4
-
-=item $c->finalize_body
-
-=cut
-
-sub finalize_body {
- my $c = shift;
- $c->apache->print( $c->response->body );
-}
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- my $c = shift;
-
- my $length = $c->request->content_length;
- my ( $buffer, $content );
-
- while ($length) {
-
- $c->apache->read( $buffer, ( $length < 8192 ) ? $length : 8192 );
-
- $length -= length($buffer);
- $content .= $buffer;
- }
-
- $c->request->body($content);
-}
-
-=item $c->prepare_connection
-
-=cut
-
-sub prepare_connection {
- my $c = shift;
- $c->request->address( $c->apache->connection->remote_ip );
- $c->request->hostname( $c->apache->connection->remote_host );
- $c->request->protocol( $c->apache->protocol );
- $c->request->user( $c->apache->user );
-
- if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
- $c->request->secure(1);
- }
-
- if ( $c->apache->get_server_port == 443 ) {
- $c->request->secure(1);
- }
-}
-
-=item $c->prepare_headers
-
-=cut
-
-sub prepare_headers {
- my $c = shift;
- $c->request->method( $c->apache->method );
- $c->request->header( %{ $c->apache->headers_in } );
-}
-
-=item $c->prepare_path
-
-=cut
-
-# XXX needs fixing, only work with <Location> directive,
-# not <Directory> directive
-sub prepare_path {
- my $c = shift;
-
- {
- my $path = $c->apache->uri;
-
- if ( my $location = $c->apache->location ) {
-
- if ( index( $path, $location ) == 0 ) {
- $path = substr( $path, length($location) );
- }
- }
-
- $path =~ s/^\///;
-
- if ( $c->apache->filename && -f $c->apache->filename && -x _ ) {
-
- my $filename = ( File::Spec->splitpath( $c->apache->filename ) )[2];
-
- if ( index( $path, $filename ) == 0 ) {
- $path = substr( $path, length($filename) );
- }
- }
-
- $path =~ s/^\///;
-
- $c->request->path($path);
- }
-
- {
- my $scheme = $c->request->secure ? 'https' : 'http';
- my $host = $c->apache->hostname;
- my $port = $c->apache->get_server_port;
- my $path = $c->apache->uri;
-
- if ( length( $c->request->path ) ) {
- $path =~ s/\/$//;
- $path = substr( $path, 0, length($path) - length($c->req->path) );
- }
-
- unless ( $path =~ /\/$/ ) {
- $path .= '/';
- }
-
- my $base = URI->new;
- $base->scheme($scheme);
- $base->host($host);
- $base->port($port);
- $base->path($path);
-
- $c->request->base( $base->canonical->as_string );
- }
-}
-
-=item $c->prepare_request($r)
-
-=cut
-
-sub prepare_request {
- my ( $c, $r ) = @_;
- $c->apache($r);
-}
-
-=item $c->run
-
-=cut
-
-sub run { shift->handler(@_) }
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst> L<Catalyst::Engine>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP13;
-
-use strict;
-use base qw[Catalyst::Engine::Apache::MP13::Base Catalyst::Engine::CGI];
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP13 - Catalyst Apache MP13 Engine
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for Apache mod_perl version 1.3x.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::MP13::Base>
-and C<Catalyst::Engine::CGI>.
-
-=over 4
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- shift->Catalyst::Engine::CGI::prepare_body(@_);
-}
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- shift->Catalyst::Engine::CGI::prepare_parameters(@_);
-}
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my ( $c, $r, @arguments ) = @_;
-
- unless ( $ENV{REQUEST_METHOD} ) {
-
- $ENV{CONTENT_TYPE} = $r->header_in("Content-Type");
- $ENV{CONTENT_LENGTH} = $r->header_in("Content-Length");
- $ENV{QUERY_STRING} = $r->args;
- $ENV{REQUEST_METHOD} = $r->method;
-
- my $cleanup = sub {
- delete( $ENV{$_} ) for qw( CONTENT_TYPE
- CONTENT_LENGTH
- QUERY_STRING
- REQUEST_METHOD );
- };
-
- $r->register_cleanup($cleanup);
- }
-
- $c->SUPER::prepare_request($r);
- $c->Catalyst::Engine::CGI::prepare_request( $r, @arguments );
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- shift->Catalyst::Engine::CGI::prepare_uploads(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP13::Apreq;
-
-use strict;
-use base 'Catalyst::Engine::Apache::MP13::Base';
-
-use Apache::Request ();
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP13::Apreq - Apreq class for MP 1.3 Engines
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for Apache mod_perl version 1.3x.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::MP13::Base>.
-
-=over 4
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- my $c = shift;
-
- my @params;
-
- $c->apache->param->do( sub {
- my ( $field, $value ) = @_;
- push( @params, $field, $value );
- return 1;
- });
-
- $c->request->param(@params);
-}
-
-=item $c->prepare_request($r)
-
-=cut
-
-sub prepare_request {
- my ( $c, $r ) = @_;
- $c->apache( Apache::Request->new($r) );
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- my $c = shift;
-
- my @uploads;
-
- for my $upload ( $c->apache->upload ) {
-
- my $object = Catalyst::Request::Upload->new(
- filename => $upload->filename,
- size => $upload->size,
- tempname => $upload->tempname,
- type => $upload->type
- );
-
- push( @uploads, $upload->name, $object );
- }
-
- $c->request->upload(@uploads);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::MP13::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP13::Base;
-
-use strict;
-use base 'Catalyst::Engine::Apache::Base';
-
-use Apache ();
-use Apache::Constants ();
-use Apache::File ();
-
-Apache::Constants->import(':common');
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP13::Base - Base class for MP 1.3 Engines
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is a base class for MP 1.3 Engines.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::Base>.
-
-=over 4
-
-=item $c->finalize_headers
-
-=cut
-
-sub finalize_headers {
- my $c = shift;
-
- for my $name ( $c->response->headers->header_field_names ) {
- next if $name =~ /^Content-(Length|Type)$/i;
- my @values = $c->response->header($name);
- $c->apache->headers_out->add( $name => $_ ) for @values;
- }
-
- if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
- my @values = $c->response->header('Set-Cookie');
- $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
- }
-
- $c->apache->status( $c->response->status );
-
- if ( my $type = $c->response->header('Content-Type') ) {
- $c->apache->content_type($type);
- }
-
- if ( my $length = $c->response->content_length ) {
- $c->apache->set_content_length($length);
- }
-
- $c->apache->send_http_header;
-
- return 0;
-}
-
-=item $c->handler
-
-=cut
-
-sub handler ($$) {
- shift->SUPER::handler(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP19;
-
-use strict;
-use base qw[Catalyst::Engine::Apache::MP19::Base Catalyst::Engine::CGI];
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP19 - Catalyst Apache MP19 Engine
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for Apache mod_perl version 1.9x.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::MP13::Base>
-and C<Catalyst::Engine::CGI>.
-
-=over 4
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- shift->Catalyst::Engine::CGI::prepare_body(@_);
-}
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- shift->Catalyst::Engine::CGI::prepare_parameters(@_);
-}
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my ( $c, $r, @arguments ) = @_;
-
- unless ( $ENV{REQUEST_METHOD} ) {
-
- $ENV{CONTENT_TYPE} = $r->headers_in->get("Content-Type");
- $ENV{CONTENT_LENGTH} = $r->headers_in->get("Content-Length");
- $ENV{QUERY_STRING} = $r->args;
- $ENV{REQUEST_METHOD} = $r->method;
-
- my $cleanup = sub {
- delete( $ENV{$_} ) for qw( CONTENT_TYPE
- CONTENT_LENGTH
- QUERY_STRING
- REQUEST_METHOD );
- };
-
- $r->pool->cleanup_register($cleanup);
- }
-
- $c->SUPER::prepare_request($r);
- $c->Catalyst::Engine::CGI::prepare_request( $r, @arguments );
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- shift->Catalyst::Engine::CGI::prepare_uploads(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP19::Apreq;
-
-use strict;
-use base 'Catalyst::Engine::Apache::MP19::Base';
-
-use Apache::Request ();
-use Apache::Upload ();
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP19::Apreq - Apreq class for MP 1.9 Engines
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for Apache mod_perl version 1.99.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::MP19::Base>.
-
-=over 4
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- my $c = shift;
-
- my @params;
-
- $c->apache->param->do( sub {
- my ( $field, $value ) = @_;
- push( @params, $field, $value );
- return 1;
- });
-
- $c->request->param(@params);
-}
-
-=item $c->prepare_request($r)
-
-=cut
-
-sub prepare_request {
- my ( $c, $r ) = @_;
- $c->apache( Apache::Request->new($r) );
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- my $c = shift;
-
- # This is a workaround for a know bug with libapreq <= 2.0.4
- # http://svn.apache.org/viewcvs.cgi?rev=122925&view=rev
-
- my @uploads;
-
- for my $field ( $c->request->param ) {
-
- for my $upload ( $c->apache->upload($field) ) {
-
- my $object = Catalyst::Request::Upload->new(
- filename => $upload->filename,
- size => $upload->size,
- tempname => $upload->tempname,
- type => $upload->type
- );
-
- push( @uploads, $field, $object );
- }
- }
-
- $c->request->upload(@uploads);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::MP19::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP19::Base;
-
-use strict;
-use base 'Catalyst::Engine::Apache::Base';
-
-use Apache2 ();
-use Apache::Connection ();
-use Apache::Const ();
-use Apache::RequestIO ();
-use Apache::RequestRec ();
-use Apache::RequestUtil ();
-use Apache::Response ();
-
-Apache::Const->import( -compile => ':common' );
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP19::Base - Base class for MP 1.9 Engines
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is a base class for MP 1.99 Engines.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::Base>.
-
-=over 4
-
-=item $c->finalize_headers
-
-=cut
-
-sub finalize_headers {
- my $c = shift;
-
- for my $name ( $c->response->headers->header_field_names ) {
- next if $name =~ /^Content-(Length|Type)$/i;
- my @values = $c->response->header($name);
- $c->apache->headers_out->add( $name => $_ ) for @values;
- }
-
- if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
- my @values = $c->response->header('Set-Cookie');
- $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
- }
-
- $c->apache->status( $c->response->status );
-
- if ( my $type = $c->response->header('Content-Type') ) {
- $c->apache->content_type($type);
- }
-
- if ( my $length = $c->response->content_length ) {
- $c->apache->set_content_length($length);
- }
-
- return 0;
-}
-
-=item $c->handler
-
-=cut
-
-sub handler : method {
- shift->SUPER::handler(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP20;
-
-use strict;
-use base qw[Catalyst::Engine::Apache::MP20::Base Catalyst::Engine::CGI];
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP20 - Catalyst Apache MP20 Engine
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for Apache mod_perl version 2.0.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::MP20::Base>
-and C<Catalyst::Engine::CGI>.
-
-=over 4
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- shift->Catalyst::Engine::CGI::prepare_body(@_);
-}
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- shift->Catalyst::Engine::CGI::prepare_parameters(@_);
-}
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my ( $c, $r, @arguments ) = @_;
-
- unless ( $ENV{REQUEST_METHOD} ) {
-
- $ENV{CONTENT_TYPE} = $r->headers_in->get("Content-Type");
- $ENV{CONTENT_LENGTH} = $r->headers_in->get("Content-Length");
- $ENV{QUERY_STRING} = $r->args;
- $ENV{REQUEST_METHOD} = $r->method;
-
- my $cleanup = sub {
- delete( $ENV{$_} ) for qw( CONTENT_TYPE
- CONTENT_LENGTH
- QUERY_STRING
- REQUEST_METHOD );
- };
-
- $r->pool->cleanup_register($cleanup);
- }
-
- $c->SUPER::prepare_request($r);
- $c->Catalyst::Engine::CGI::prepare_request( $r, @arguments );
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- shift->Catalyst::Engine::CGI::prepare_uploads(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP20::Apreq;
-
-use strict;
-use base 'Catalyst::Engine::Apache::MP20::Base';
-
-use Apache2::Request ();
-use Apache2::Upload ();
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP20::Apreq - Apreq class for MP 2.0 Engines
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for Apache mod_perl version 2.0.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::MP20::Base>.
-
-=over 4
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- my $c = shift;
-
- my @params;
-
- if ( my $table = $c->apache->param ) {
-
- $table->do( sub {
- my ( $field, $value ) = @_;
- push( @params, $field, $value );
- return 1;
- });
-
- $c->request->param(@params);
- }
-}
-
-=item $c->prepare_request($r)
-
-=cut
-
-sub prepare_request {
- my ( $c, $r ) = @_;
- $c->apache( Apache2::Request->new($r) );
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- my $c = shift;
-
- my @uploads;
-
- $c->apache->upload->do( sub {
- my ( $field, $upload ) = @_;
-
- my $object = Catalyst::Request::Upload->new(
- filename => $upload->filename,
- size => $upload->size,
- tempname => $upload->tempname,
- type => $upload->type
- );
-
- push( @uploads, $field, $object );
-
- return 1;
- });
-
- $c->request->upload(@uploads);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::MP20::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::Apache::MP20::Base;
-
-use strict;
-use base 'Catalyst::Engine::Apache::Base';
-
-use Apache2::Connection ();
-use Apache2::Const ();
-use Apache2::RequestIO ();
-use Apache2::RequestRec ();
-use Apache2::RequestUtil ();
-use Apache2::Response ();
-
-Apache2::Const->import( -compile => ':common' );
-
-=head1 NAME
-
-Catalyst::Engine::Apache::MP20::Base - Base class for MP 2.0 Engines
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is a base class for MP 2.0 Engines.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::Apache::Base>.
-
-=over 4
-
-=item $c->finalize_headers
-
-=cut
-
-sub finalize_headers {
- my $c = shift;
-
- for my $name ( $c->response->headers->header_field_names ) {
- next if $name =~ /^Content-(Length|Type)$/i;
- my @values = $c->response->header($name);
- $c->apache->headers_out->add( $name => $_ ) for @values;
- }
-
- if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
- my @values = $c->response->header('Set-Cookie');
- $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
- }
-
- $c->apache->status( $c->response->status );
-
- if ( my $type = $c->response->header('Content-Type') ) {
- $c->apache->content_type($type);
- }
-
- if ( my $length = $c->response->content_length ) {
- $c->apache->set_content_length($length);
- }
-
- return 0;
-}
-
-=item $c->handler
-
-=cut
-
-sub handler : method {
- shift->SUPER::handler(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
package Catalyst::Engine::CGI;
use strict;
-use base 'Catalyst::Engine::CGI::Base';
-
-use Catalyst::Exception;
-use CGI;
-
-our @compile = qw[
- delete
- http
- new_MultipartBuffer
- param
- parse_keywordlist
- read_from_client
- read_multipart
- tmpFileName
- uploadInfo
- url_param
- user_agent
-];
-
-CGI->compile(@compile);
-
-__PACKAGE__->mk_accessors('cgi');
+use base 'Catalyst::Engine';
+use NEXT;
+use URI;
+use URI::Query;
=head1 NAME
=head1 DESCRIPTION
-This is the Catalyst engine specialized for the CGI environment (using the
-C<CGI> and C<CGI::Cookie> modules).
-
-=head1 METHODS
-
-=over 4
-
-=item $c->cgi
-
-Contains the C<CGI> object.
-
-=back
+This is the Catalyst engine specialized for the CGI environment.
=head1 OVERLOADED METHODS
-This class overloads some methods from C<Catalyst::Engine::CGI::Base>.
+This class overloads some methods from C<Catalyst::Engine>.
=over 4
-=item $c->prepare_body
+=item $self->finalize_headers($c)
=cut
-sub prepare_body {
- my $c = shift;
+sub finalize_headers {
+ my ( $self, $c ) = @_;
- # XXX this is undocumented in CGI.pm. If Content-Type is not
- # application/x-www-form-urlencoded or multipart/form-data
- # CGI.pm will read STDIN into a param, POSTDATA.
+ $c->response->header( Status => $c->response->status );
- $c->request->body( $c->cgi->param('POSTDATA') );
+ print $c->response->headers->as_string("\015\012");
+ print "\015\012";
}
-=item $c->prepare_parameters
+=item $self->prepare_connection($c)
=cut
-sub prepare_parameters {
- my $c = shift;
-
- my ( @params );
-
- if ( $c->request->method eq 'POST' ) {
- for my $param ( $c->cgi->url_param ) {
- for my $value ( $c->cgi->url_param($param) ) {
- push ( @params, $param, $value );
- }
+sub prepare_connection {
+ my ( $self, $c ) = @_;
+
+ $c->request->address( $ENV{REMOTE_ADDR} );
+
+ PROXY_CHECK:
+ {
+ unless ( $c->config->{using_frontend_proxy} ) {
+ last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
+ last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
}
+ last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
+
+ # If we are running as a backend server, the user will always appear
+ # as 127.0.0.1. Select the most recent upstream IP (last in the list)
+ my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
+ $c->request->address( $ip );
}
- for my $param ( $c->cgi->param ) {
- for my $value ( $c->cgi->param($param) ) {
- push ( @params, $param, $value );
- }
+ $c->request->hostname( $ENV{REMOTE_HOST} );
+ $c->request->protocol( $ENV{SERVER_PROTOCOL} );
+ $c->request->user( $ENV{REMOTE_USER} );
+ $c->request->method( $ENV{REQUEST_METHOD} );
+
+ if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
+ $c->request->secure(1);
}
- $c->request->param(@params);
+ if ( $ENV{SERVER_PORT} == 443 ) {
+ $c->request->secure(1);
+ }
}
-=item $c->prepare_request
+=item $self->prepare_headers($c)
=cut
-sub prepare_request {
- my ( $c, $object ) = @_;
-
- my $cgi;
-
- if ( defined($object) && ref($object) ) {
+sub prepare_headers {
+ my ( $self, $c ) = @_;
- if ( $object->isa('Apache') ) { # MP 1.3
- $cgi = CGI->new($object);
- }
+ # Read headers from %ENV
+ while ( my ( $header, $value ) = each %ENV ) {
+ next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i;
+ ( my $field = $header ) =~ s/^HTTPS?_//;
+ $c->req->headers->header( $field => $value );
+ }
+}
- elsif ( $object->isa('Apache::RequestRec') ) { # MP 1.99
- $cgi = CGI->new($object);
- }
+=item $self->prepare_path($c)
- elsif ( $object->isa('Apache2::RequestRec') ) { # MP 2.00
- $cgi = CGI->new($object);
- }
+=cut
- elsif ( $object->isa('CGI') ) {
- $cgi = $object;
+sub prepare_path {
+ my ( $self, $c ) = @_;
+
+ my $scheme = $c->request->secure ? 'https' : 'http';
+ my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
+ my $port = $ENV{SERVER_PORT} || 80;
+ my $base_path = $ENV{SCRIPT_NAME} || '/';
+
+ # If we are running as a backend proxy, get the true hostname
+ PROXY_CHECK:
+ {
+ unless ( $c->config->{using_frontend_proxy} ) {
+ last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
+ last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
}
+ last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
- else {
- my $class = ref($object);
-
- Catalyst::Exception->throw(
- message => qq/Unknown object '$object'/
- );
- }
+ $host = $ENV{HTTP_X_FORWARDED_HOST};
+ # backend could be on any port, so
+ # assume frontend is on the default port
+ $port = $c->request->secure ? 443 : 80;
}
- $c->cgi( $cgi || CGI->new );
+ my $path = $base_path . $ENV{PATH_INFO};
+ $path =~ s{^/+}{};
+
+ my $uri = URI->new;
+ $uri->scheme( $scheme );
+ $uri->host( $host );
+ $uri->port( $port );
+ $uri->path( $path );
+ $uri->query( $ENV{QUERY_STRING} ) if $ENV{QUERY_STRING};
+
+ # sanitize the URI
+ $uri = $uri->canonical;
+ $c->request->uri( $uri );
+
+ # set the base URI
+ # base must end in a slash
+ $base_path .= '/' unless ( $base_path =~ /\/$/ );
+ my $base = $uri->clone;
+ $base->path_query( $base_path );
+ $c->request->base( $base );
}
-=item $c->prepare_uploads
+=item $self->prepare_query_parameters($c)
=cut
-sub prepare_uploads {
- my $c = shift;
+sub prepare_query_parameters {
+ my ( $self, $c ) = @_;
+
+ my $u = URI::Query->new( $ENV{QUERY_STRING} );
+ $c->request->query_parameters( { $u->hash } );
+}
- my @uploads;
+=item $self->prepare_write($c)
- for my $param ( $c->cgi->param ) {
+Enable autoflush on the output handle for CGI-based engines.
- my @values = $c->cgi->param($param);
+=cut
- next unless ref( $values[0] );
+sub prepare_write {
+ my ( $self, $c ) = @_;
+
+ # Set the output handle to autoflush
+ $c->response->handle->autoflush(1);
+
+ $self->NEXT::prepare_write( $c );
+}
- for my $fh (@values) {
+=item $self->read_chunk($c, $buffer, $length)
- next unless my $size = ( stat $fh )[7];
+=cut
- my $info = $c->cgi->uploadInfo($fh);
- my $tempname = $c->cgi->tmpFileName($fh);
- my $type = $info->{'Content-Type'};
- my $disposition = $info->{'Content-Disposition'};
- my $filename = ( $disposition =~ / filename="([^;]*)"/ )[0];
+sub read_chunk { shift; shift->request->handle->sysread( @_ ); }
- my $upload = Catalyst::Request::Upload->new(
- filename => $filename,
- size => $size,
- tempname => $tempname,
- type => $type
- );
+=item $self->run
- push( @uploads, $param, $upload );
- }
- }
+=cut
- $c->request->upload(@uploads);
-}
+sub run { shift; shift->handle_request(@_) }
=back
=head1 SEE ALSO
-L<Catalyst> L<Catalyst::Engine> L<Catalyst::Engine::CGI::Base>.
+L<Catalyst> L<Catalyst::Engine>.
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri@cpan.org>
-=head1 AUTHOR
+Christian Hansen, <ch@ngmedia.com>
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
+Andy Grundman, <andy@hybridized.org>
=head1 COPYRIGHT
+++ /dev/null
-package Catalyst::Engine::CGI::APR;
-
-use strict;
-use base 'Catalyst::Engine::CGI::Base';
-
-use APR;
-use APR::Pool;
-use APR::Request;
-use APR::Request::CGI;
-use APR::Request::Param;
-
-__PACKAGE__->mk_accessors( qw[apr pool] );
-
-=head1 NAME
-
-Catalyst::Engine::CGI::APR - The CGI APR Engine
-
-=head1 SYNOPSIS
-
-A script using the Catalyst::Engine::CGI::APR module might look like:
-
- #!/usr/bin/perl -w
-
- BEGIN {
- $ENV{CATALYST_ENGINE} = 'CGI::APR';
- }
-
- use strict;
- use lib '/path/to/MyApp/lib';
- use MyApp;
-
- MyApp->run;
-
-=head1 DESCRIPTION
-
-This Catalyst engine uses C<APR::Request::CGI> for parsing of message body.
-
-=head1 METHODS
-
-=over 4
-
-=item $c->apr
-
-Contains the C<APR::Request::CGI> object.
-
-=item $c->pool
-
-Contains the C<APR::Pool> object.
-
-=back
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::CGI::Base>.
-
-=over 4
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- my $c = shift;
-
- my @params;
-
- if ( my $table = $c->apr->param ) {
-
- $table->do( sub {
- my ( $field, $value ) = @_;
- push( @params, $field, $value );
- return 1;
- });
-
- $c->request->param(@params);
- }
-}
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my $c = shift;
- $c->pool( APR::Pool->new );
- $c->apr( APR::Request::CGI->handle( $c->pool ) );
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- my $c = shift;
-
- my @uploads;
-
- if ( my $body = $c->apr->body ) {
-
- $body->param_class('APR::Request::Param');
-
- $body->uploads( $c->pool )->do( sub {
- my ( $field, $upload ) = @_;
-
- my $object = Catalyst::Request::Upload->new(
- filename => $upload->upload_filename,
- size => $upload->upload_size,
- tempname => $upload->upload_tempname,
- type => $upload->upload_type
- );
-
- push( @uploads, $field, $object );
-
- return 1;
- });
-
- $c->request->upload(@uploads);
- }
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<APR::Request::CGI>, L<Catalyst::Engine::CGI::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::CGI::Base;
-
-use strict;
-use base 'Catalyst::Engine';
-
-use URI;
-use URI::http;
-
-=head1 NAME
-
-Catalyst::Engine::CGI::Base - Base class for CGI Engines
-
-=head1 DESCRIPTION
-
-This is a base class for CGI engines.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine>.
-
-=over 4
-
-=item $c->finalize_body
-
-Prints the response output to STDOUT.
-
-=cut
-
-sub finalize_body {
- my $c = shift;
- print $c->response->output;
-}
-
-=item $c->finalize_headers
-
-=cut
-
-sub finalize_headers {
- my $c = shift;
-
- $c->response->header( Status => $c->response->status );
-
- print $c->response->headers->as_string("\015\012");
- print "\015\012";
-}
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- my $c = shift;
-
- my $body = undef;
-
- while ( read( STDIN, my $buffer, 8192 ) ) {
- $body .= $buffer;
- }
-
- $c->request->body($body);
-}
-
-=item $c->prepare_connection
-
-=cut
-
-sub prepare_connection {
- my $c = shift;
- $c->request->address( $ENV{REMOTE_ADDR} );
- $c->request->hostname( $ENV{REMOTE_HOST} );
- $c->request->protocol( $ENV{SERVER_PROTOCOL} );
- $c->request->user( $ENV{REMOTE_USER} );
-
- if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
- $c->request->secure(1);
- }
-
- if ( $ENV{SERVER_PORT} == 443 ) {
- $c->request->secure(1);
- }
-}
-
-=item $c->prepare_headers
-
-=cut
-
-sub prepare_headers {
- my $c = shift;
-
- while ( my ( $header, $value ) = each %ENV ) {
-
- next unless $header =~ /^(HTTP|CONTENT)/i;
-
- ( my $field = $header ) =~ s/^HTTPS?_//;
-
- $c->req->headers->header( $field => $value );
- }
-
- $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
-}
-
-=item $c->prepare_path
-
-=cut
-
-sub prepare_path {
- my $c = shift;
-
- my $base;
- {
- my $scheme = $c->request->secure ? 'https' : 'http';
- my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
- my $port = $ENV{SERVER_PORT} || 80;
- my $path = $ENV{SCRIPT_NAME} || '/';
-
- unless ( $path =~ /\/$/ ) {
- $path .= '/';
- }
-
- $base = URI->new;
- $base->scheme($scheme);
- $base->host($host);
- $base->port($port);
- $base->path($path);
-
- $base = $base->canonical->as_string;
- }
-
- my $location = $ENV{SCRIPT_NAME} || '/';
- my $path = $ENV{PATH_INFO} || '/';
- $path =~ s/^($location)?\///;
- $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
- $path =~ s/^\///;
-
- $c->req->base($base);
- $c->req->path($path);
-}
-
-=item $c->run
-
-=cut
-
-sub run { shift->handler(@_) }
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
package Catalyst::Engine::FastCGI;
use strict;
-use base qw(Catalyst::Engine::FastCGI::Base Catalyst::Engine::CGI);
+use base 'Catalyst::Engine::CGI';
+use FCGI;
=head1 NAME
-Catalyst::Engine::FastCGI - Catalyst FastCGI Engine
-
-=head1 SYNOPSIS
-
-A script using the Catalyst::Engine::FastCGI module might look like:
-
- #!/usr/bin/perl -w
-
- BEGIN {
- $ENV{CATALYST_ENGINE} = 'FastCGI';
- }
-
- use strict;
- use lib '/path/to/MyApp/lib';
- use MyApp;
-
- MyApp->run;
+Catalyst::Engine::FastCGI - FastCGI Engine
=head1 DESCRIPTION
-This is the Catalyst engine for FastCGI.
+This is the FastCGI engine.
=head1 OVERLOADED METHODS
-This class overloads some methods from C<Catalyst::Engine::FastCGI::Base>
-and C<Catalyst::Engine::CGI>.
+This class overloads some methods from C<Catalyst::Engine::CGI>.
=over 4
-=item $c->prepare_body
+=item $self->run($c)
=cut
-sub prepare_body {
- shift->Catalyst::Engine::CGI::prepare_body(@_);
-}
+sub run {
+ my ( $self, $class ) = @_;
-=item $c->prepare_parameters
+ my $request = FCGI::Request();
-=cut
-
-sub prepare_parameters {
- shift->Catalyst::Engine::CGI::prepare_parameters(@_);
+ while ( $request->Accept >= 0 ) {
+ $class->handle_request;
+ }
}
-=item $c->prepare_request
+=item $self->write($c, $buffer)
=cut
-sub prepare_request {
- my ( $c, $request, @arguments ) = @_;
- CGI::_reset_globals();
- $c->SUPER::prepare_request($request);
- $c->Catalyst::Engine::CGI::prepare_request(@arguments);
+sub write {
+ my ( $self, $c, $buffer ) = @_;
+
+ unless ( $self->{_prepared_write} ) {
+ $self->prepare_write( $c );
+ $self->{_prepared_write} = 1;
+ }
+
+ # FastCGI does not stream data properly if using 'print $handle',
+ # but a syswrite appears to work properly.
+ $c->response->handle->syswrite( $buffer );
}
-=item $c->prepare_uploads
-
-=cut
+=back
-sub prepare_uploads {
- shift->Catalyst::Engine::CGI::prepare_uploads(@_);
-}
+=head1 SEE ALSO
-=back
+L<Catalyst>, L<FCGI>.
-=head1 SEE ALSO
+=head1 AUTHORS
-L<Catalyst>, L<Catalyst::Engine::FastCGI::Base>, L<Catalyst::Engine::CGI>.
+Sebastian Riedel, <sri@cpan.org>
-=head1 AUTHOR
+Christian Hansen, <ch@ngmedia.com>
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
+Andy Grundman, <andy@hybridized.org>
=head1 COPYRIGHT
+++ /dev/null
-package Catalyst::Engine::FastCGI::APR;
-
-use strict;
-use base qw(Catalyst::Engine::FastCGI::Base Catalyst::Engine::CGI::APR);
-
-=head1 NAME
-
-Catalyst::Engine::FastCGI::APR - Catalyst FastCGI APR Engine
-
-=head1 SYNOPSIS
-
-A script using the Catalyst::Engine::FastCGI::APR module might look like:
-
- #!/usr/bin/perl -w
-
- BEGIN {
- $ENV{CATALYST_ENGINE} = 'FastCGI::APR';
- }
-
- use strict;
- use lib '/path/to/MyApp/lib';
- use MyApp;
-
- MyApp->run;
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine for FastCGI and APR.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::FastCGI::Base>.
-
-=over 4
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- shift->Catalyst::Engine::CGI::APR::prepare_body(@_);
-}
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- shift->Catalyst::Engine::CGI::APR::prepare_parameters(@_);
-}
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my ( $c, $fastcgi, @arguments ) = @_;
- $c->SUPER::prepare_request($fastcgi);
- $c->Catalyst::Engine::CGI::APR::prepare_request(@arguments);
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- shift->Catalyst::Engine::CGI::APR::prepare_uploads(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine::FastCGI::Base>, L<Catalyst::Engine::CGI::APR>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::FastCGI::Base;
-
-use strict;
-use base 'Catalyst::Engine::CGI::Base';
-
-use FCGI;
-
-__PACKAGE__->mk_accessors('fastcgi');
-
-=head1 NAME
-
-Catalyst::Engine::FastCGI::Base - Base class for FastCGI Engines
-
-=head1 DESCRIPTION
-
-This is a base class for FastCGI engines.
-
-=head1 METHODS
-
-=over 4
-
-=item $c->fastcgi
-
-Contains the C<FCGI::Request> object.
-
-=back
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::CGI::Base>.
-
-=over 4
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my ( $c, $request ) = @_;
- $c->fastcgi($request);
-}
-
-=item $c->run
-
-=cut
-
-sub run {
- my ( $class, @arguments ) = @_;
-
- my $request = FCGI::Request();
-
- while ( $request->Accept >= 0 ) {
- $class->handler( $request, @arguments );
- }
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<FCGI>, L<Catalyst::Engine::CGI::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
package Catalyst::Engine::HTTP;
use strict;
-use base 'Catalyst::Engine::HTTP::Daemon';
+use base 'Catalyst::Engine::CGI';
+use Errno 'EWOULDBLOCK';
+use HTTP::Status;
+use NEXT;
+use Socket;
=head1 NAME
This is the Catalyst engine specialized for development and testing.
+=head1 METHODS
+
+=over 4
+
+=item $self->finalize_headers($c)
+
+=cut
+
+sub finalize_headers {
+ my ( $self, $c ) = @_;
+ my $protocol = $c->request->protocol;
+ my $status = $c->response->status;
+ my $message = status_message($status);
+ print "$protocol $status $message\015\012";
+ $c->response->headers->date(time);
+ $self->NEXT::finalize_headers($c);
+}
+
+=item $self->finalize_read($c)
+
+=cut
+
+sub finalize_read {
+ my ( $self, $c ) = @_;
+
+ # Never ever remove this, it would result in random length output
+ # streams if STDIN eq STDOUT (like in the HTTP engine)
+ $c->request->handle->blocking(1);
+
+ return $self->NEXT::finalize_read($c);
+}
+
+=item $self->prepare_read($c)
+
+=cut
+
+sub prepare_read {
+ my ( $self, $c ) = @_;
+
+ # Set the input handle to non-blocking
+ $c->request->handle->blocking(0);
+
+ return $self->NEXT::prepare_read($c);
+}
+
+=item $self->read_chunk($c, $buffer, $length)
+
+=cut
+
+sub read_chunk {
+ my $self = shift;
+ my $c = shift;
+
+ # support for non-blocking IO
+ my $handle = $c->request->handle;
+ my $rin = '';
+ vec( $rin, $handle->fileno, 1 ) = 1;
+
+ READ:
+ {
+ select( $rin, undef, undef, undef );
+ my $rc = $handle->sysread(@_);
+ if ( defined $rc ) {
+ return $rc;
+ }
+ else {
+ next READ if $! == EWOULDBLOCK;
+ return;
+ }
+ }
+}
+
+=item run
+
+=cut
+
+# A very very simple HTTP server that initializes a CGI environment
+sub run {
+ my ( $self, $class, $port, $host, $fork ) = @_;
+
+ our $GOT_HUP;
+ local $GOT_HUP = 0;
+
+ local $SIG{HUP} = sub { $GOT_HUP = 1; };
+
+ local $SIG{CHLD} = 'IGNORE';
+
+ # Handle requests
+
+ # Setup socket
+ $host = $host ? inet_aton($host) : INADDR_ANY;
+ socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') );
+ setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) );
+ bind( HTTPDaemon, sockaddr_in( $port, $host ) );
+ listen( HTTPDaemon, SOMAXCONN );
+ my $url = 'http://';
+ if ( $host eq INADDR_ANY ) {
+ require Sys::Hostname;
+ $url .= lc Sys::Hostname::hostname();
+ }
+ else {
+ $url .= gethostbyaddr( $host, AF_INET ) || inet_ntoa($host);
+ }
+ $url .= ":$port";
+ print "You can connect to your server at $url\n";
+ my $pid = undef;
+ while ( accept( Remote, HTTPDaemon ) ) {
+
+ # Fork
+ if ($fork) { next if $pid = fork }
+
+ close HTTPDaemon if defined $pid;
+
+ # Ignore broken pipes as an HTTP server should
+ local $SIG{PIPE} = sub { close Remote };
+ local $SIG{HUP} = (defined $pid ? 'IGNORE' : $SIG{HUP});
+
+ local *STDIN = \*Remote;
+ local *STDOUT = \*Remote;
+ select STDOUT;
+
+ # Request data
+ my $remote_sockaddr = getpeername( \*Remote );
+ my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
+ my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
+ my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
+ my $local_sockaddr = getsockname( \*Remote );
+ my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
+ my $localname = gethostbyaddr( $localiaddr, AF_INET )
+ || "localhost";
+ my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1";
+
+ STDIN->blocking(1);
+
+ # Parse request line
+ my $line = $self->_get_line( \*STDIN );
+ next
+ unless my ( $method, $uri, $protocol ) =
+ $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/;
+
+ # We better be careful and just use 1.0
+ $protocol = '1.0';
+
+ my ( $path, $query_string ) = split /\?/, $uri, 2;
+
+ # Initialize CGI environment
+ local %ENV = (
+ PATH_INFO => $path || '',
+ QUERY_STRING => $query_string || '',
+ REMOTE_ADDR => $peeraddr,
+ REMOTE_HOST => $peername,
+ REQUEST_METHOD => $method || '',
+ SERVER_NAME => $localname,
+ SERVER_PORT => $port,
+ SERVER_PROTOCOL => "HTTP/$protocol",
+ %ENV,
+ );
+
+ # Parse headers
+ if ( $protocol >= 1 ) {
+ while (1) {
+ my $line = $self->_get_line( \*STDIN );
+ last if $line eq '';
+ next
+ unless my ( $name, $value ) =
+ $line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/;
+
+ $name = uc $name;
+ $name = 'COOKIE' if $name eq 'COOKIES';
+ $name =~ tr/-/_/;
+ $name = 'HTTP_' . $name
+ unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
+ if ( exists $ENV{$name} ) {
+ $ENV{$name} .= "; $value";
+ }
+ else {
+ $ENV{$name} = $value;
+ }
+ }
+ }
+
+ # Pass flow control to Catalyst
+ $class->handle_request;
+ exit if defined $pid;
+ }
+ continue {
+ close Remote;
+ }
+ close HTTPDaemon;
+ exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @ARGV ) if $GOT_HUP;
+}
+
+sub _get_line {
+ my ( $self, $handle ) = @_;
+
+ my $line = '';
+
+ while ( sysread( $handle, my $byte, 1 ) ) {
+ last if $byte eq "\012"; # eol
+ $line .= $byte;
+ }
+
+ 1 while $line =~ s/\s\z//;
+
+ return $line;
+}
+
+=back
+
=head1 SEE ALSO
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Daemon>.
+L<Catalyst>, L<Catalyst::Engine>.
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri@cpan.org>
+
+Dan Kubb, <dan.kubb-cpan@onautopilot.com>
-=head1 AUTHOR
+=head1 THANKS
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
+Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
=head1 COPYRIGHT
+++ /dev/null
-package Catalyst::Engine::HTTP::Base;
-
-use strict;
-use base 'Catalyst::Engine';
-
-use Catalyst::Exception;
-use Class::Struct ();
-use HTTP::Headers::Util 'split_header_words';
-use HTTP::Request;
-use HTTP::Response;
-use File::Temp;
-use URI;
-
-__PACKAGE__->mk_accessors(qw/http/);
-
-Class::Struct::struct 'Catalyst::Engine::HTTP::Base::struct' => {
- request => 'HTTP::Request',
- response => 'HTTP::Response',
- hostname => '$',
- address => '$'
-};
-
-=head1 NAME
-
-Catalyst::Engine::HTTP::Base - Base class for HTTP Engines
-
-=head1 DESCRIPTION
-
-This is a base class for HTTP Engines.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine>.
-
-=over 4
-
-=item $c->finalize_body
-
-=cut
-
-sub finalize_body {
- my $c = shift;
- $c->http->response->content( $c->response->body );
-}
-
-=item $c->finalize_headers
-
-=cut
-
-sub finalize_headers {
- my $c = shift;
-
- $c->http->response->code( $c->response->status );
-
- for my $name ( $c->response->headers->header_field_names ) {
- $c->http->response->push_header( $name => [ $c->response->header($name) ] );
- }
-}
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- my $c = shift;
- $c->request->body( $c->http->request->content );
-}
-
-=item $c->prepare_connection
-
-=cut
-
-sub prepare_connection {
- my $c = shift;
- $c->request->address( $c->http->address );
- $c->request->hostname( $c->http->hostname );
- $c->request->protocol( $c->http->request->protocol );
- $c->request->secure(1) if ( $c->http->request->uri->port == 443 );
-}
-
-=item $c->prepare_headers
-
-=cut
-
-sub prepare_headers {
- my $c = shift;
- $c->request->method( $c->http->request->method );
- $c->request->headers( $c->http->request->headers );
-}
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- my $c = shift;
-
- my ( @params, @uploads );
-
- my $request = $c->http->request;
-
- push( @params, $request->uri->query_form );
-
- if ( $request->content_type eq 'application/x-www-form-urlencoded' ) {
- my $uri = URI->new('http:');
- $uri->query( $request->content );
- push( @params, $uri->query_form );
- }
-
- if ( $request->content_type eq 'multipart/form-data' ) {
-
- for my $part ( $request->parts ) {
-
- my $disposition = $part->header('Content-Disposition');
- my %parameters = @{ ( split_header_words($disposition) )[0] };
-
- if ( $parameters{filename} ) {
-
- my $fh = File::Temp->new( UNLINK => 0 );
-
- unless ( $fh->write( $part->content ) ) {
- Catalyst::Exception->throw( message => $! );
- }
-
- unless ( $fh->flush ) {
- Catalyst::Exception->throw( message => $! );
- }
-
- my $upload = Catalyst::Request::Upload->new(
- filename => $parameters{filename},
- size => ( $fh->stat )[7],
- tempname => $fh->filename,
- type => $part->content_type
- );
-
- unless ( $fh->close ) {
- Catalyst::Exception->throw( message => $! );
- }
-
- push( @uploads, $parameters{name}, $upload );
- push( @params, $parameters{name}, $parameters{filename} );
- }
- else {
- push( @params, $parameters{name}, $part->content );
- }
- }
- }
-
- $c->request->param(@params);
- $c->request->upload(@uploads);
-}
-
-=item $c->prepare_path
-
-=cut
-
-sub prepare_path {
- my $c = shift;
-
- my $base;
- {
- my $scheme = $c->http->request->uri->scheme;
- my $host = $c->http->request->uri->host;
- my $port = $c->http->request->uri->port;
-
- $base = URI->new;
- $base->scheme($scheme);
- $base->host($host);
- $base->port($port);
-
- $base = $base->canonical->as_string;
- }
-
- my $path = $c->http->request->uri->path || '/';
- $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
- $path =~ s/^\///;
-
- $c->req->base($base);
- $c->req->path($path);
-}
-
-=item $c->prepare_request($r)
-
-=cut
-
-sub prepare_request {
- my ( $c, $http ) = @_;
- $c->http($http);
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- my $c = shift;
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::HTTP::Daemon;
-
-use strict;
-use base 'Catalyst::Engine::HTTP::Base';
-
-use Catalyst::Exception;
-use IO::Select;
-use IO::Socket;
-
-BEGIN {
-
- if ( $^O eq 'MSWin32' ) {
-
- *EINTR = sub { 10004 };
- *EINPROGRESS = sub { 10036 };
- *EWOULDBLOCK = sub { 10035 };
- *F_GETFL = sub { 0 };
- *F_SETFL = sub { 0 };
-
- *IO::Socket::blocking = sub {
- my ( $self, $blocking ) = @_;
- my $nonblocking = $blocking ? 0 : 1;
- ioctl( $self, 0x8004667e, \$nonblocking );
- };
- }
-
- else {
- Errno->require;
- Errno->import( qw[EWOULDBLOCK EINPROGRESS EINTR] );
- }
-}
-
-=head1 NAME
-
-Catalyst::Engine::HTTP::Daemon - Catalyst HTTP Daemon Engine
-
-=head1 SYNOPSIS
-
-A script using the Catalyst::Engine::HTTP::Daemon module might look like:
-
- #!/usr/bin/perl -w
-
- BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP::Daemon' }
-
- use strict;
- use lib '/path/to/MyApp/lib';
- use MyApp;
-
- MyApp->run;
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for development and testing.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::HTTP::Base>.
-
-=over 4
-
-=item $c->handler
-
-=cut
-
-sub handler {
- my ( $class, $request, $response, $client ) = @_;
-
- $request->uri->scheme('http'); # Force URI::http
- $request->uri->host( $request->header('Host') || $client->sockhost );
- $request->uri->port( $client->sockport );
-
- my $http = Catalyst::Engine::HTTP::Base::struct->new(
- address => $client->peerhost,
- request => $request,
- response => $response
- );
-
- $class->SUPER::handler($http);
-}
-
-=item $c->run
-
-=cut
-
-sub run {
- my $class = shift;
- my $port = shift || 3000;
-
- $SIG{'PIPE'} = 'IGNORE';
-
- my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new(
- Listen => SOMAXCONN,
- LocalPort => $port,
- ReuseAddr => 1,
- Timeout => 5
- );
-
- unless ( defined $daemon ) {
-
- Catalyst::Exception->throw(
- message => qq/Failed to create daemon. Reason: '$!'/
- );
- }
-
- my $base = URI->new( $daemon->url )->canonical;
-
- printf( "You can connect to your server at %s\n", $base );
-
- my $select = IO::Select->new($daemon);
-
- while (1) {
-
- for my $client ( $select->can_read(0.01) ) {
-
- if ( $client == $daemon ) {
- $client = $daemon->accept;
- $client->timestamp = time;
- $client->blocking(0);
- $select->add($client);
- }
-
- else {
- next if $client->request;
- next if $client->response;
-
- my $nread = $client->sysread( my $buf, 4096 );
-
- unless ( $nread ) {
-
- next if $! == EWOULDBLOCK;
- next if $! == EINPROGRESS;
- next if $! == EINTR;
-
- $select->remove($client);
- $client->close;
-
- next;
- }
-
- $client->request_buffer .= $buf;
-
- if ( my $request = $client->get_request ) {
- $client->request = $request;
- $client->timestamp = time
- }
- }
- }
-
- for my $client ( $select->handles ) {
-
- next if $client == $daemon;
-
- if ( ( time - $client->timestamp ) > 60 ) {
-
- $select->remove($client);
- $client->close;
-
- next;
- }
-
- next if $client->response;
- next unless $client->request;
-
- $client->response = HTTP::Response->new;
- $client->response->protocol( $client->request->protocol );
-
- $class->handler( $client->request, $client->response, $client );
- }
-
- for my $client ( $select->can_write(0.01) ) {
-
- next unless $client->response;
-
- unless ( $client->response_buffer ) {
-
- $client->response->header( Server => $daemon->product_tokens );
-
- my $connection = $client->request->header('Connection') || '';
-
- if ( $connection =~ /Keep-Alive/i ) {
- $client->response->header( 'Connection' => 'Keep-Alive' );
- $client->response->header( 'Keep-Alive' => 'timeout=60, max=100' );
- }
-
- if ( $connection =~ /close/i ) {
- $client->response->header( 'Connection' => 'close' );
- }
-
- $client->response_buffer = $client->response->as_string("\x0D\x0A");
- $client->response_offset = 0;
- }
-
- my $nwrite = $client->syswrite( $client->response_buffer,
- $client->response_length,
- $client->response_offset );
-
- unless ( $nwrite ) {
-
- next if $! == EWOULDBLOCK;
- next if $! == EINPROGRESS;
- next if $! == EINTR;
-
- $select->remove($client);
- $client->close;
-
- next;
- }
-
- $client->response_offset += $nwrite;
-
- if ( $client->response_offset == $client->response_length ) {
-
- my $connection = $client->request->header('Connection') || '';
- my $protocol = $client->request->protocol;
- my $persistent = 0;
-
- if ( $protocol eq 'HTTP/1.1' && $connection !~ /close/i ) {
- $persistent++;
- }
-
- if ( $protocol ne 'HTTP/1.1' && $connection =~ /Keep-Alive/i ) {
- $persistent++;
- }
-
- unless ( $persistent ) {
- $select->remove($client);
- $client->close;
- }
-
- $client->response = undef;
- $client->request = undef;
- $client->response_buffer = undef;
- }
- }
- }
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>,
-L<HTTP::Daemon>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-package Catalyst::Engine::HTTP::Daemon::Catalyst;
-
-use strict;
-use base 'HTTP::Daemon';
-
-sub accept {
- return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client');
-}
-
-sub product_tokens {
- return "Catalyst/$Catalyst::VERSION";
-}
-
-package Catalyst::Engine::HTTP::Daemon::Client;
-
-use strict;
-use base 'HTTP::Daemon::ClientConn';
-
-sub request : lvalue {
- my $self = shift;
- ${*$self}{'request'};
-}
-
-sub request_buffer : lvalue {
- my $self = shift;
- ${*$self}{'httpd_rbuf'};
-}
-
-sub response : lvalue {
- my $self = shift;
- ${*$self}{'response'};
-}
-
-sub response_buffer : lvalue {
- my $self = shift;
- ${*$self}{'httpd_wbuf'};
-}
-
-sub response_length {
- my $self = shift;
- return length( $self->response_buffer );
-}
-
-sub response_offset : lvalue {
- my $self = shift;
- ${*$self}{'httpd_woffset'};
-}
-
-sub timestamp : lvalue {
- my $self = shift;
- ${*$self}{'timestamp'};
-}
-
-1;
+++ /dev/null
-package Catalyst::Engine::SpeedyCGI;
-
-use strict;
-use base qw(Catalyst::Engine::SpeedyCGI::Base Catalyst::Engine::CGI);
-
-=head1 NAME
-
-Catalyst::Engine::SpeedyCGI - Catalyst SpeedyCGI Engine
-
-=head1 SYNOPSIS
-
-A script using the Catalyst::Engine::SpeedyCGI module might look like:
-
- #!/usr/bin/speedy -w
-
- BEGIN {
- $ENV{CATALYST_ENGINE} = 'SpeedyCGI';
- }
-
- use strict;
- use lib '/path/to/MyApp/lib';
- use MyApp;
-
- MyApp->run;
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine for SpeedyCGI.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::SpeedyCGI::Base>
-and C<Catalyst::Engine::CGI>.
-
-=over 4
-
-=item $c->prepare_body
-
-=cut
-
-sub prepare_body {
- shift->Catalyst::Engine::CGI::prepare_body(@_);
-}
-
-=item $c->prepare_parameters
-
-=cut
-
-sub prepare_parameters {
- shift->Catalyst::Engine::CGI::prepare_parameters(@_);
-}
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my ( $c, $speedycgi, @arguments ) = @_;
- $speedycgi->register_cleanup( \&CGI::_reset_globals );
- $c->SUPER::prepare_request($speedycgi);
- $c->Catalyst::Engine::CGI::prepare_request(@arguments);
-}
-
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- shift->Catalyst::Engine::CGI::prepare_uploads(@_);
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine::SpeedyCGI::Base>, L<Catalyst::Engine::CGI>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package Catalyst::Engine::SpeedyCGI::Base;
-
-use strict;
-use base 'Catalyst::Engine::CGI::Base';
-
-use CGI::SpeedyCGI;
-
-__PACKAGE__->mk_accessors('speedycgi');
-
-=head1 NAME
-
-Catalyst::Engine::SpeedyCGI::Base - Base class for SpeedyCGI Engines
-
-=head1 DESCRIPTION
-
-This is a base class for SpeedyCGI engines.
-
-=head1 METHODS
-
-=over 4
-
-=item $c->speedycgi
-
-Contains the C<CGI::SpeedyCGI> object.
-
-=back
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::CGI::Base>.
-
-=over 4
-
-=item $c->prepare_request
-
-=cut
-
-sub prepare_request {
- my ( $c, $speedycgi ) = @_;
- $c->speedycgi($speedycgi);
-}
-
-=item $c->run
-
-=cut
-
-sub run {
- my ( $class, @arguments ) = @_;
- $class->handler( CGI::SpeedyCGI->new, @arguments );
-}
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<CGI::SpeedyCGI>, L<Catalyst::Engine::CGI::Base>.
-
-=head1 AUTHOR
-
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
-
-=head1 COPYRIGHT
-
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
package Catalyst::Engine::Test;
use strict;
-use base 'Catalyst::Engine::HTTP::Base';
-
+use base 'Catalyst::Engine::CGI';
use Catalyst::Utils;
+use HTTP::Response;
+use HTTP::Status;
+use NEXT;
=head1 NAME
=head1 OVERLOADED METHODS
-This class overloads some methods from C<Catalyst::Engine::HTTP::Base>.
+This class overloads some methods from C<Catalyst::Engine::CGI>.
=over 4
-=item $c->run
+=item finalize_headers
+
+=cut
+
+sub finalize_headers {
+ my ( $self, $c ) = @_;
+ my $protocol = $c->request->protocol;
+ my $status = $c->response->status;
+ my $message = status_message($status);
+ print "$protocol $status $message\n";
+ $c->response->headers->date(time);
+ $self->NEXT::finalize_headers($c);
+}
+
+=item $self->run($c)
=cut
sub run {
- my ( $class, $request ) = @_;
-
+ my ( $self, $class, $request ) = @_;
+
$request = Catalyst::Utils::request($request);
- $request->header(
+ $request->header(
'Host' => sprintf( '%s:%d', $request->uri->host, $request->uri->port )
);
- my $http = Catalyst::Engine::HTTP::Base::struct->new(
- address => '127.0.0.1',
- hostname => 'localhost',
- request => $request,
- response => HTTP::Response->new
+ # We emulate CGI
+ local %ENV = (
+ PATH_INFO => $request->uri->path || '',
+ QUERY_STRING => $request->uri->query || '',
+ REMOTE_ADDR => '127.0.0.1',
+ REMOTE_HOST => 'localhost',
+ REQUEST_METHOD => $request->method,
+ SERVER_NAME => 'localhost',
+ SERVER_PORT => $request->uri->port,
+ SERVER_PROTOCOL => 'HTTP/1.1',
+ %ENV,
);
- $http->response->date(time);
+ # Headers
+ for my $header ( $request->header_field_names ) {
+ my $name = uc $header;
+ $name = 'COOKIE' if $name eq 'COOKIES';
+ $name =~ tr/-/_/;
+ $name = 'HTTP_' . $name
+ unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
+ my $value = $request->header($header);
+ if ( exists $ENV{$name} ) {
+ $ENV{$name} .= "; $value";
+ }
+ else {
+ $ENV{$name} = $value;
+ }
+ }
+
+ # STDIN
+ local *STDIN;
+ my $input = $request->content;
+ open STDIN, '<', \$input;
+
+ # STDOUT
+ local *STDOUT;
+ my $output = '';
+ open STDOUT, '>', \$output;
- $class->handler($http);
+ # Process
+ $class->handle_request;
- return $http->response;
+ # Response
+ return HTTP::Response->parse($output);
}
+=item $self->read_chunk($c, $buffer, $length)
+
+=cut
+
+sub read_chunk { shift; shift->request->handle->read( @_ ); }
+
=back
=head1 SEE ALSO
L<Catalyst>.
-=head1 AUTHOR
+=head1 AUTHORS
+
+Sebastian Riedel, <sri@cpan.org>
+
+Christian Hansen, <ch@ngmedia.com>
-Sebastian Riedel, C<sri@cpan.org>
-Christian Hansen, C<ch@ngmedia.com>
+Andy Grundman, <andy@hybridized.org>
=head1 COPYRIGHT
my @args = @_;
my $class = "Catalyst::Helper::$helper";
eval "require $class";
-
- if ( $@ ) {
- Catalyst::Exception->throw(
- message => qq/Couldn't load helper "$class", "$@"/
- );
+
+ if ($@) {
+ Catalyst::Exception->throw(
+ message => qq/Couldn't load helper "$class", "$@"/ );
}
-
+
if ( $class->can('mk_stuff') ) {
return 1 unless $class->mk_stuff( $self, @args );
}
$comp = 'Controller' if $type eq 'C';
my $class = "Catalyst::Helper::$comp\::$helper";
eval "require $class";
-
- if ( $@ ) {
- Catalyst::Exception->throw(
- message => qq/Couldn't load helper "$class", "$@"/
- );
- }
-
+
+ if ($@) {
+ Catalyst::Exception->throw(
+ message => qq/Couldn't load helper "$class", "$@"/ );
+ }
+
if ( $class->can('mk_compclass') ) {
return 1 unless $class->mk_compclass( $self, @args );
}
print qq/created "$dir"\n/;
return 1;
}
-
- Catalyst::Exception->throw(
- message => qq/Couldn't create "$dir", "$!"/
- );
+
+ Catalyst::Exception->throw( message => qq/Couldn't create "$dir", "$!"/ );
}
=head3 mk_file
if ( -e $file ) {
print qq/ exists "$file"\n/;
return 0 unless $self->{'.newfiles'};
- if ( my $f = IO::File->new("< $file") ) {
- my $oldcontent = join('', (<$f>));
- return 0 if $content eq $oldcontent;
- }
- $file .= '.new';
+ if ( my $f = IO::File->new("< $file") ) {
+ my $oldcontent = join( '', (<$f>) );
+ return 0 if $content eq $oldcontent;
+ }
+ $file .= '.new';
}
if ( my $f = IO::File->new("> $file") ) {
print $f $content;
print qq/created "$file"\n/;
return 1;
}
-
- Catalyst::Exception->throw(
- message => qq/Couldn't create "$file", "$!"/
- );
+
+ Catalyst::Exception->throw( message => qq/Couldn't create "$file", "$!"/ );
}
=head3 next_test
$prefix = $prefix;
$tname = $prefix . '.t';
$self->{prefix} = $prefix;
- $prefix = lc $prefix;
+ $prefix = lc $prefix;
$prefix =~ s/-/\//g;
$self->{uri} = $prefix;
}
my $template = $self->get_file( ( caller(0) )[0], $file );
return 0 unless $template;
my $output;
- $t->process( \$template, { %{$self}, %$vars }, \$output );
+ $t->process( \$template, { %{$self}, %$vars }, \$output )
+ || Catalyst::Exception->throw(
+ message => qq/Couldn't process "$file", / . $t->error() );
$self->mk_file( $path, $output );
}
sub default : Private {
my ( $self, $c ) = @_;
- $c->res->output('Congratulations, [% name %] is on Catalyst!');
+
+ # Hello World
+ $c->response->output('Congratulations, [% name %] is on Catalyst!');
}
+#=item end
+#
+#=cut
+#
+#sub end : Private {
+# my ( $self, $c ) = @_;
+#
+# # Forward to View unless response body is already defined
+# $c->forward('MyApp::V::') unless $c->response->body;
+#}
+
=back
=head1 AUTHOR
-[%author%]
+[% author %]
=head1 LICENSE
use lib "$FindBin::Bin/../lib";
use [% name %];
+my $fork = 0;
my $help = 0;
+my $host = undef;
my $port = 3000;
-GetOptions( 'help|?' => \$help, 'port=s' => \$port );
+GetOptions(
+ 'fork' => \$fork,
+ 'help|?' => \$help,
+ 'host=s' => \$host,
+ 'port=s' => \$port
+);
pod2usage(1) if $help;
-[% name %]->run($port);
+[% name %]->run( $port, $host, $fork );
1;
[% appprefix %]_server.pl [options]
Options:
+ -f -fork handle each request in a new process
-? -help display this help and exits
+ -host host (defaults to all)
-p -port port (defaults to 3000)
See also:
sub default : Private {
my ( $self, $c ) = @_;
- $c->res->output('Congratulations, [% class %] is on Catalyst!');
+
+ # Hello World
+ $c->response->output('Congratulations, [% class %] is on Catalyst!');
}
=back
use IO::Socket qw[AF_INET inet_aton];
__PACKAGE__->mk_accessors(
- qw/action address arguments body base cookies headers match method
- parameters path protocol secure snippets uploads user/
+ qw/action address arguments base cookies handle headers match method
+ protocol query_parameters secure snippets uri user/
);
-*args = \&arguments;
-*input = \&body;
-*params = \¶meters;
+*args = \&arguments;
+*body_params = \&body_parameters;
+*input = \&body;
+*params = \¶meters;
+*query_params = \&query_parameters;
+*path_info = \&path;
sub content_encoding { shift->headers->content_encoding(@_) }
-sub content_length { shift->headers->content_length(@_) }
-sub content_type { shift->headers->content_type(@_) }
-sub header { shift->headers->header(@_) }
-sub referer { shift->headers->referer(@_) }
-sub user_agent { shift->headers->user_agent(@_) }
+sub content_length { shift->headers->content_length(@_) }
+sub content_type { shift->headers->content_type(@_) }
+sub header { shift->headers->header(@_) }
+sub referer { shift->headers->referer(@_) }
+sub user_agent { shift->headers->user_agent(@_) }
=head1 NAME
$req->arguments;
$req->base;
$req->body;
+ $req->body_parameters;
$req->content_encoding;
$req->content_length;
$req->content_type;
$req->cookie;
$req->cookies;
- $req->full_uri;
+ $req->handle;
$req->header;
$req->headers;
$req->hostname;
$req->parameters;
$req->path;
$req->protocol;
+ $req->query_parameters;
+ $req->read;
$req->referer;
$req->secure;
$req->snippets;
print $c->request->body
+=cut
+
+sub body {
+ my ( $self, $body ) = @_;
+ $self->{_context}->prepare_body;
+ return $self->{_body}->body;
+}
+
+=item $req->body_parameters
+
+Returns a reference to a hash containing body parameters. Values can
+be either a scalar or an arrayref containing scalars.
+
+ print $c->request->body_parameters->{field};
+ print $c->request->body_parameters->{field}->[0];
+
+=item $req->body_params
+
+An alias for body_parameters.
+
+=cut
+
+sub body_parameters {
+ my ( $self, $params ) = @_;
+ $self->{_context}->prepare_body;
+ $self->{body_parameters} = $params if $params;
+ return $self->{body_parameters};
+}
+
=item $req->content_encoding
Shortcut to $req->headers->content_encoding
unless ( exists $self->cookies->{$name} ) {
return undef;
}
-
+
return $self->cookies->{$name};
}
}
print $c->request->cookies->{mycookie}->value;
-=item $req->full_uri
+=item $req->handle
-Returns the complete URI, with the parameter query string.
-
-=cut
-
-sub full_uri {
- my $self = shift;
- my $full_uri = $self->uri;
-
- if ( scalar $self->param ) {
- my @params;
- foreach my $arg ( sort keys %{ $self->params } ) {
- if ( ref $self->params->{$arg} ) {
- my $list = $self->params->{$arg};
- push @params, map { "$arg=" . $_ } sort @{$list};
- } else {
- push @params, "$arg=" . $self->params->{$arg};
- }
- }
- $full_uri .= '?' . join( '&', @params );
- }
- return $full_uri;
-}
+Request IO handle.
=item $req->header
my $self = shift;
if ( @_ == 0 && not $self->{hostname} ) {
- $self->{hostname} = gethostbyaddr( inet_aton( $self->address ), AF_INET );
+ $self->{hostname} =
+ gethostbyaddr( inet_aton( $self->address ), AF_INET );
}
if ( @_ == 1 ) {
if ( @_ > 1 ) {
while ( my ( $field, $value ) = splice( @_, 0, 2 ) ) {
-
+
next unless defined $field;
if ( exists $self->parameters->{$field} ) {
print $c->request->parameters->{field};
print $c->request->parameters->{field}->[0];
+=cut
+
+sub parameters {
+ my ( $self, $params ) = @_;
+ $self->{_context}->prepare_body;
+ $self->{parameters} = $params if $params;
+ return $self->{parameters};
+}
+
=item $req->path
Contains the path.
print $c->request->path;
+=item $req->path_info
+
+alias for path, added for compability with L<CGI>
+
+=cut
+
+sub path {
+ my ( $self, $params ) = @_;
+
+ if ( $params ) {
+ # base must always have a trailing slash
+ $params .= '/' unless ( $params =~ /\/$/ );
+ $self->uri->path( $params );
+ }
+
+ my $path = $self->uri->path;
+ my $location = $self->base->path;
+ $path =~ s/^(\Q$location\E)?//;
+ $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ $path =~ s/^\///;
+
+ return $path;
+}
+
=item $req->protocol
Contains the protocol.
+=item $req->query_parameters
+
+Returns a reference to a hash containing query parameters. Values can
+be either a scalar or an arrayref containing scalars.
+
+ print $c->request->query_parameters->{field};
+ print $c->request->query_parameters->{field}->[0];
+
+=item $req->read( [$maxlength] )
+
+Read a chunk of data from the request body. This method is designed to be
+used in a while loop, reading $maxlength bytes on every call. $maxlength
+defaults to the size of the request if not specified.
+
+You have to set MyApp->config->{parse_on_demand} to use this directly.
+
+=cut
+
+sub read { shift->{_context}->read(@_); }
+
=item $req->referer
Shortcut to $req->headers->referer. Referring page.
}
else {
return (wantarray)
- ? ( $self->uploads->{$upload} )
- : $self->uploads->{$upload};
+ ? ( $self->uploads->{$upload} )
+ : $self->uploads->{$upload};
}
}
my $upload = $c->request->uploads->{field};
my $upload = $c->request->uploads->{field}->[0];
-=item $req->uri
-
-Shortcut for C<< $req->base . $req->path >>.
-
=cut
-sub uri {
- my $self = shift;
- my $path = shift || $self->path || '';
- return $self->base . $path;
+sub uploads {
+ my ( $self, $uploads ) = @_;
+ $self->{_context}->prepare_body;
+ $self->{uploads} = $uploads if $uploads;
+ return $self->{uploads};
}
+=item $req->uri
+
+Returns a URI object for the request.
+
=item $req->user
Contains the user name of user if authentication check was successful.
*output = \&body;
sub content_encoding { shift->headers->content_encoding(@_) }
-sub content_length { shift->headers->content_length(@_) }
-sub content_type { shift->headers->content_type(@_) }
-sub header { shift->headers->header(@_) }
+sub content_length { shift->headers->content_length(@_) }
+sub content_type { shift->headers->content_type(@_) }
+sub header { shift->headers->header(@_) }
=head1 NAME
=head1 SYNOPSIS
- $resp = $c->response;
- $resp->body;
- $resp->content_encoding;
- $resp->content_length;
- $resp->content_type;
- $resp->cookies;
- $resp->header;
- $resp->headers;
- $resp->output;
- $resp->redirect;
- $resp->status;
+ $res = $c->response;
+ $res->body;
+ $res->content_encoding;
+ $res->content_length;
+ $res->content_type;
+ $res->cookies;
+ $res->handle;
+ $res->header;
+ $res->headers;
+ $res->output;
+ $res->redirect;
+ $res->status;
+ $res->write;
See also L<Catalyst::Application>.
=over 4
-=item $resp->body($text)
+=item $res->body($text)
$c->response->body('Catalyst rocks!');
Contains the final output.
-=item $resp->content_encoding
+=item $res->content_encoding
-Shortcut to $resp->headers->content_encoding
+Shortcut to $res->headers->content_encoding
-=item $resp->content_length
+=item $res->content_length
-Shortcut to $resp->headers->content_length
+Shortcut to $res->headers->content_length
-=item $resp->content_type
+=item $res->content_type
-Shortcut to $resp->headers->content_type
+Shortcut to $res->headers->content_type
-=item $resp->cookies
+=item $res->cookies
Returns a reference to a hash containing the cookies to be set.
$c->response->cookies->{foo} = { value => '123' };
-=item $resp->header
+=item $res->handle
-Shortcut to $resp->headers->header
+Response IO handle.
-=item $resp->headers
+=cut
+
+sub handle {
+ my ( $self, $handle ) = @_;
+
+ if ($handle) {
+ $self->{handle} = $handle;
+ }
+ else {
+ # Finalize headers if someone touches the output handle
+ if ( $self->{_context} ) {
+ $self->{_context}->finalize_headers;
+ }
+ }
+
+ return $self->{handle};
+}
+
+=item $res->header
+
+Shortcut to $res->headers->header
+
+=item $res->headers
Returns a L<HTTP::Headers> object containing the headers.
$c->response->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
-=item $resp->output
+=item $res->output
-Shortcut to $resp->body
+Shortcut to $res->body
-=item $resp->redirect( $url, $status )
+=item $res->redirect( $url, $status )
Contains a location to redirect to.
sub redirect {
my $self = shift;
-
- if ( @_ ) {
+
+ if (@_) {
my $location = shift;
my $status = shift || 302;
return $self->location;
}
-=item status
+=item $res->status
Contains the HTTP status.
$c->response->status(404);
+
+=item $res->write( $data )
+
+Writes $data to the output stream.
+
+=cut
+
+sub write { shift->{_context}->write(@_); }
=back
+++ /dev/null
- [x] /engine/request/body.t
- [x] /engine/request/cookies.t
- [x] /engine/request/headers.t
- [ ] /engine/request/method/get.t
- [ ] /engine/request/method/head.t
- [ ] /engine/request/method/post/multipart.t
- [ ] /engine/request/method/post/urlencoded.t
- [x] /engine/request/parameters.t
- [ ] /engine/request/unicode.t
- [x] /engine/request/uploads.t
-
- [x] /engine/response/cookies.t
- [x] /engine/response/errors.t
- [~] /engine/response/headers.t
- [x] /engine/response/status.t
- [x] /engine/response/redirect.t
- [ ] /engine/response/unicode.t
-
- [ ] /model/error.t
- [ ] /model/subclass.t
-
- [ ] /view/dump.t
- [ ] /view/error.t
- [ ] /view/subclass.t
- [ ] /view/unicode.t
-
- [ ] /component/controller/action/arguments.t
- [~] /component/controller/action/begin.t
- [~] /component/controller/action/default.t
- [~] /component/controller/action/end.t
- [~] /component/controller/action/forward.t
- [~] /component/controller/action/global.t
- [~] /component/controller/action/inheritance.t
- [~] /component/controller/action/local.t
- [~] /component/controller/action/path.t
- [~] /component/controller/acrion/private.t
- [ ] /component/controller/action/public.t
- [~] /component/controller/action/regexp.t
-
- [ ] /plugin/overload/finalize.t
- [ ] /plugin/overload/finalize_output.t
- [ ] /plugin/overload/prepare_uploads.t
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/../../../lib";
-
-use Test::More tests=>7;
-use Catalyst::Test 'TestApp';
-
-
-{
- my @expected = qw[
- TestApp::Controller::Action::Begin->begin
- TestApp::Controller::Action::Begin->default
- TestApp::View::Dump::Request->process
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/begin'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
- is( $response->header('X-Test-Class'), 'TestApp::Controller::Action::Begin', 'Test Class' );
- is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
-}
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/../../lib";
-
-use Test::More tests => 10;
-use Catalyst::Test 'TestApp';
-
-use Catalyst::Request;
-use HTTP::Headers;
-use HTTP::Request::Common;
-use URI;
-
-{
- my $creq;
-
- my $request = GET( 'http://localhost/dump/request',
- 'User-Agent' => 'MyAgen/1.0',
- 'X-Whats-Cool' => 'Catalyst'
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- isa_ok( $creq, 'Catalyst::Request' );
- isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
- is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
- is( $creq->header('User-Agent'), $request->header('User-Agent'), 'Catalyst::Request->header User-Agent' );
-
- my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
- is( $creq->header('Host'), $host, 'Catalyst::Request->header Host' );
-}
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/../../lib";
-
-use Test::More tests => 7;
-use Catalyst::Test 'TestApp';
-
-
-{
- my $expected = join( ', ', 1 .. 10 );
-
- ok( my $response = request('http://localhost/engine/response/headers/one'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->code, 200, 'Response Code' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/headers/one', 'Test Action' );
- is( $response->header('X-Header-Catalyst'), 'Cool', 'Response Header X-Header-Catalyst' );
- is( $response->header('X-Header-Cool'), 'Catalyst', 'Response Header X-Header-Cool' );
- is( $response->header('X-Header-Numbers'), $expected, 'Response Header X-Header-Numbers' );
-}
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/../../lib";
-
-use Test::More tests => 1;
-use Catalyst::Test 'TestApp';
-
-{
- # Allow overriding automatic root.
- is(TestApp->config->{root},'/Users/chansen/src/MyApp/root');
-}
+++ /dev/null
-package TestApp::View::Dump;
-
-use strict;
-use base qw[Catalyst::Base];
-
-use Data::Dumper ();
-
-sub dump {
- my ( $self, $reference ) = @_;
-
- return unless $reference;
-
- my $dumper = Data::Dumper->new( [ $reference ] );
- $dumper->Indent(1);
- $dumper->Purity(1);
- $dumper->Useqq(0);
- $dumper->Deepcopy(1);
- $dumper->Quotekeys(0);
- $dumper->Terse(1);
-
- return $dumper->Dump;
-}
-
-sub process {
- my ( $self, $c, $reference ) = @_;
-
- if ( my $output = $self->dump( $reference || $c->stash->{dump} || $c->stash ) ) {
-
- $c->res->headers->content_type('text/plain');
- $c->res->output($output);
- return 1;
- }
-
- return 0;
-}
-
-1;
+++ /dev/null
-package TestApp::View::Dump::False;
-
-use strict;
-use base qw[TestApp::View::Dump::Request];
-use overload
- '""' => sub { undef; };
-
-1;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../../../lib";
+
+use Test::More tests => 7;
+use Catalyst::Test 'TestApp';
+
+{
+ my @expected = qw[
+ TestApp::Controller::Action::Begin->begin
+ TestApp::Controller::Action::Begin->default
+ TestApp::View::Dump::Request->process
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/begin'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Begin',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+}
--- /dev/null
+#!perl\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use FindBin;\r
+use lib "$FindBin::Bin/../../../lib";\r
+\r
+use Test::More tests => 18;\r
+use Catalyst::Test 'TestApp';\r
+\r
+\r
+{\r
+ my @expected = qw[\r
+ TestApp::Controller::Action::Detach->begin\r
+ TestApp::Controller::Action::Detach->one\r
+ TestApp::Controller::Action::Detach->two\r
+ TestApp::View::Dump::Request->process\r
+ ];\r
+\r
+ my $expected = join( ", ", @expected );\r
+\r
+ # Test detach to chain of actions.\r
+ ok( my $response = request('http://localhost/action/detach/one'), 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );\r
+ is( $response->header('X-Catalyst-Action'), 'action/detach/one', 'Test Action' );\r
+ is( $response->header('X-Test-Class'), 'TestApp::Controller::Action::Detach', 'Test Class' );\r
+ is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' );\r
+}\r
+\r
+{\r
+ my @expected = qw[\r
+ TestApp::Controller::Action::Detach->begin\r
+ TestApp::Controller::Action::Detach->path\r
+ TestApp::Controller::Action::Detach->two\r
+ TestApp::View::Dump::Request->process\r
+ ];\r
+\r
+ my $expected = join( ", ", @expected );\r
+\r
+ # Test detach to chain of actions.\r
+ ok( my $response = request('http://localhost/action/detach/path'), 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );\r
+ is( $response->header('X-Catalyst-Action'), 'action/detach/path', 'Test Action' );\r
+ is( $response->header('X-Test-Class'), 'TestApp::Controller::Action::Detach', 'Test Class' );\r
+ is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' );\r
+}\r
+\r
+{\r
+ ok( my $response = request('http://localhost/action/detach/with_args/old'), 'Request with args' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ is( $response->content, 'new');\r
+}\r
+\r
+{\r
+ ok( my $response = request('http://localhost/action/detach/with_method_and_args/old'), 'Request with args and method' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ is( $response->content, 'new');\r
+}\r
use FindBin;
use lib "$FindBin::Bin/../../../lib";
-use Test::More tests => 31;
+use Test::More tests => 24;
use Catalyst::Test 'TestApp';
{
my @expected = qw[
TestApp::Controller::Action::Forward->begin
- TestApp::Controller::Action::Forward->six
- TestApp::View::Dump::False->process
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/forward/six'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'action/forward/six', 'Main Class Action' );
- is( $response->header('X-Test-Class'), 'TestApp::Controller::Action::Forward', 'Test Class' );
- is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
-}
-
-{
- my @expected = qw[
- TestApp::Controller::Action::Forward->begin
TestApp::Controller::Action::Forward->jojo
TestApp::Controller::Action::Forward->one
TestApp::Controller::Action::Forward->two
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../../../lib";
+
+use Test::More tests => 4;
+use Catalyst::Test 'TestApp';
+
+{
+ ok( my $response = request('http://localhost/streaming'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content,, <<'EOF', 'Content is a stream' );
+foo
+bar
+baz
+EOF
+}
use FindBin;
use lib "$FindBin::Bin/../../lib";
-use Test::More tests => 20;
+use Test::More tests => 18;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
{
my $creq;
- my $request = POST( 'http://localhost/dump/request/',
+ my $request = POST(
+ 'http://localhost/dump/request/',
'Content-Type' => 'text/plain',
'Content' => 'Hello Catalyst'
);
ok( my $response = request($request), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
-
+ like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+
{
no strict 'refs';
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
}
isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length, 'Catalyst::Request Content-Length' );
- is( $creq->body, $request->content, 'Catalyst::Request Content' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
}
{
my $creq;
- my $request = POST( 'http://localhost/dump/request/',
+ my $request = POST(
+ 'http://localhost/dump/request/',
'Content-Type' => 'text/plain',
'Content' => 'x' x 100_000
);
ok( my $response = request($request), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
-
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
{
no strict 'refs';
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
}
isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length, 'Catalyst::Request Content-Length' );
- is( $creq->body, $request->content, 'Catalyst::Request Content' );
-}
\ No newline at end of file
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+}
{
my $creq;
- my $request = GET( 'http://localhost/dump/request',
- 'Cookie' => 'Catalyst=Cool; Cool=Catalyst',
- );
-
+ my $request = GET( 'http://localhost/dump/request',
+ 'Cookie' => 'Catalyst=Cool; Cool=Catalyst', );
+
ok( my $response = request($request), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
+ like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
isa_ok( $creq, 'Catalyst::Request' );
isa_ok( $creq->cookies->{Catalyst}, 'CGI::Cookie', 'Cookie Catalyst' );
is( $creq->cookies->{Catalyst}->name, 'Catalyst', 'Cookie Catalyst name' );
is( $creq->cookies->{Catalyst}->value, 'Cool', 'Cookie Catalyst value' );
isa_ok( $creq->cookies->{Cool}, 'CGI::Cookie', 'Cookie Cool' );
- is( $creq->cookies->{Cool}->name, 'Cool', 'Cookie Cool name' );
+ is( $creq->cookies->{Cool}->name, 'Cool', 'Cookie Cool name' );
is( $creq->cookies->{Cool}->value, 'Catalyst', 'Cookie Cool value' );
-
- my $cookies = {
+ my $cookies = {
Catalyst => $creq->cookies->{Catalyst},
Cool => $creq->cookies->{Cool}
};
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 16;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+use URI;
+
+{
+ my $creq;
+
+ my $request = GET( 'http://localhost/dump/request',
+ 'User-Agent' => 'MyAgen/1.0',
+ 'X-Whats-Cool' => 'Catalyst',
+ 'X-Forwarded-Host' => 'frontend.server.com',
+ 'X-Forwarded-For' => '192.168.1.1, 1.2.3.4',
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ isa_ok( $creq, 'Catalyst::Request' );
+ isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
+ is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
+ is( $creq->header('User-Agent'), $request->header('User-Agent'), 'Catalyst::Request->header User-Agent' );
+
+ my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
+ is( $creq->header('Host'), $host, 'Catalyst::Request->header Host' );
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} && $ENV{CATALYST_SERVER} !~ /127.0.0.1|localhost/ ) {
+ skip "Using remote server", 2;
+ }
+
+ is( $creq->base, 'http://frontend.server.com/', 'Catalyst::Request proxied base' );
+ is( $creq->address, '1.2.3.4', 'Catalyst::Request proxied address' );
+ }
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 4;
+ }
+ # test that we can ignore the proxy support
+ TestApp->config->{ignore_frontend_proxy} = 1;
+ ok( $response = request($request), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->base, 'http://localhost/', 'Catalyst::Request non-proxied base' );
+ is( $creq->address, '127.0.0.1', 'Catalyst::Request non-proxied address' );
+ }
+}
use FindBin;
use lib "$FindBin::Bin/../../lib";
-use Test::More tests => 19;
+use Test::More tests => 28;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
{
my $creq;
- my $parameters = {
- 'a' => [qw(A b C d E f G)],
- };
-
+ my $parameters = { 'a' => [qw(A b C d E f G)], };
+
my $query = join( '&', map { 'a=' . $_ } @{ $parameters->{a} } );
-
- ok( my $response = request("http://localhost/dump/request?$query"), 'Request' );
+
+ ok( my $response = request("http://localhost/dump/request?$query"),
+ 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'GET', 'Catalyst::Request method' );
- is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' );
+ is_deeply( $creq->{parameters}, $parameters,
+ 'Catalyst::Request parameters' );
}
{
my $creq;
- my $parameters = {
+ my $parameters = {
'a' => [qw(A b C d E f G)],
'%' => [ '%', '"', '& - &' ],
};
- my $request = POST( 'http://localhost/dump/request/a/b?a=1&a=2&a=3',
+ my $request = POST(
+ 'http://localhost/dump/request/a/b?a=1&a=2&a=3',
'Content' => $parameters,
'Content-Type' => 'application/x-www-form-urlencoded'
);
- # Query string. I'm not sure the order is consistent in all enviroments,
- # we need to test this with:
- # [x] C::E::Test and C::E::HTTP
- # [x] MP13
- # [x] MP19
- # [x] MP20
- # [x] CGI
-
unshift( @{ $parameters->{a} }, 1, 2, 3 );
-
+
ok( my $response = request($request), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'POST', 'Catalyst::Request method' );
- is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' );
+ is_deeply( $creq->{parameters}, $parameters,
+ 'Catalyst::Request parameters' );
is_deeply( $creq->arguments, [qw(a b)], 'Catalyst::Request arguments' );
- is_deeply( $creq->uploads, {}, 'Catalyst::Request uploads' );
- is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' );
+ is_deeply( $creq->{uploads}, {}, 'Catalyst::Request uploads' );
+ is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' );
}
-__END__
# http://dev.catalyst.perl.org/ticket/37
# multipart/form-data parameters that contain 'http://'
-# Not testing in trunk because this is an HTTP::Message bug
-# http://rt.cpan.org/NoAuth/Bug.html?id=13025
+# was an HTTP::Message bug, but HTTP::Body handles it properly now
{
my $creq;
ok( my $response = request($request), 'Request' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' );
+ is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
+}
+
+# raw query string support
+{
+ my $creq;
+
+ my $parameters = {
+ a => 1,
+ };
+
+ my $request = POST(
+ 'http://localhost/dump/request/a/b?query_string',
+ 'Content' => $parameters,
+ 'Content-Type' => 'application/x-www-form-urlencoded'
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->{uri}->query, 'query_string', 'Catalyst::Request POST query_string' );
+
+ ok( $response = request('http://localhost/dump/request/a/b?x=1&y=1&z=1'), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->{uri}->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' );
}
use FindBin;
use lib "$FindBin::Bin/../../lib";
-use Test::More tests => 43;
+use Test::More tests => 49;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
{
my $creq;
- my $request = POST( 'http://localhost/dump/request/',
- 'Content-Type' => 'multipart/form-data',
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'form-data',
'Content' => [
- 'cookies.t' => [ "$FindBin::Bin/cookies.t" ],
- 'headers.t' => [ "$FindBin::Bin/headers.t" ],
- 'uploads.t' => [ "$FindBin::Bin/uploads.t" ],
- ]
+ 'cookies.t' => ["$FindBin::Bin/cookies.t"],
+ 'headers.t' => ["$FindBin::Bin/headers.t"],
+ 'uploads.t' => ["$FindBin::Bin/uploads.t"],
+ ]
);
ok( my $response = request($request), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
-
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
{
no strict 'refs';
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
}
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'POST', 'Catalyst::Request method' );
- is( $creq->content_type, 'multipart/form-data', 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length, 'Catalyst::Request Content-Length' );
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
for my $part ( $request->parts ) {
my $disposition = $part->header('Content-Disposition');
my %parameters = @{ ( split_header_words($disposition) )[0] };
- my $upload = $creq->uploads->{ $parameters{filename} };
-
+ my $upload = $creq->{uploads}->{ $parameters{filename} };
+
isa_ok( $upload, 'Catalyst::Request::Upload' );
is( $upload->type, $part->content_type, 'Upload Content-Type' );
is( $upload->size, length( $part->content ), 'Upload Content-Length' );
+
+ ok( ! -e $upload->tempname, 'Upload temp file was deleted' );
}
}
{
my $creq;
- my $request = POST( 'http://localhost/dump/request/',
+ my $request = POST(
+ 'http://localhost/dump/request/',
'Content-Type' => 'multipart/form-data',
'Content' => [
- 'testfile' => [ "$FindBin::Bin/cookies.t" ],
- 'testfile' => [ "$FindBin::Bin/headers.t" ],
- 'testfile' => [ "$FindBin::Bin/uploads.t" ],
- ]
+ 'testfile' => ["$FindBin::Bin/cookies.t"],
+ 'testfile' => ["$FindBin::Bin/headers.t"],
+ 'testfile' => ["$FindBin::Bin/uploads.t"],
+ ]
);
ok( my $response = request($request), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
-
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
{
no strict 'refs';
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
}
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'POST', 'Catalyst::Request method' );
- is( $creq->content_type, 'multipart/form-data', 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length, 'Catalyst::Request Content-Length' );
-
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+
my @parts = $request->parts;
- for ( my $i = 0; $i < @parts; $i++ ) {
-
+ for ( my $i = 0 ; $i < @parts ; $i++ ) {
+
my $part = $parts[$i];
my $disposition = $part->header('Content-Disposition');
my %parameters = @{ ( split_header_words($disposition) )[0] };
-
- my $upload = $creq->uploads->{ $parameters{name} }->[$i];
-
+
+ my $upload = $creq->{uploads}->{ $parameters{name} }->[$i];
+
isa_ok( $upload, 'Catalyst::Request::Upload' );
is( $upload->type, $part->content_type, 'Upload Content-Type' );
is( $upload->filename, $parameters{filename}, 'Upload filename' );
is( $upload->size, length( $part->content ), 'Upload Content-Length' );
+
+ ok( ! -e $upload->tempname, 'Upload temp file was deleted' );
}
}
{
my $creq;
- my $request = POST( 'http://localhost/engine/request/uploads/slurp',
+ my $request = POST(
+ 'http://localhost/engine/request/uploads/slurp',
'Content-Type' => 'multipart/form-data',
- 'Content' => [
- 'slurp' => [ "$FindBin::Bin/uploads.t" ],
- ]
+ 'Content' => [ 'slurp' => ["$FindBin::Bin/uploads.t"], ]
);
ok( my $response = request($request), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->content, ($request->parts)[0]->content, 'Content' );
+ is( $response->content, ( $request->parts )[0]->content, 'Content' );
}
--- /dev/null
+#!perl\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use FindBin;\r
+use lib "$FindBin::Bin/../../lib";\r
+\r
+use Test::More tests => 18;\r
+use Catalyst::Test 'TestApp';\r
+use Catalyst::Request;\r
+\r
+my $creq;\r
+\r
+# test that the path can be changed\r
+{\r
+ ok( my $response = request('http://localhost/engine/request/uri/change_path'), 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );\r
+ like( $creq->uri, qr{/my/app/lives/here}, 'URI contains new path' );\r
+}\r
+\r
+# test that path properly removes the base location\r
+{\r
+ ok( my $response = request('http://localhost/engine/request/uri/change_base'), 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );\r
+ like( $creq->base, qr{/new/location}, 'Base URI contains new location' );\r
+ is( $creq->path, 'engine/request/uri/change_base', 'URI contains correct path' );\r
+}\r
+\r
+# test that base + path is correct\r
+{\r
+ ok( my $response = request('http://localhost/engine/request/uri'), 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );\r
+ is( $creq->base . $creq->path, $creq->uri, 'Base + Path ok' );\r
+}\r
+\r
+# test that we can use semi-colons as separators\r
+{\r
+ my $parameters = {\r
+ a => [ qw/1 2/ ],\r
+ b => 3,\r
+ };\r
+ \r
+ ok( my $response = request('http://localhost/engine/request/uri?a=1;a=2;b=3'), 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );\r
+ is( $creq->{uri}->query, 'a=1;a=2;b=3', 'Query string ok' );\r
+ is_deeply( $creq->{parameters}, $parameters, 'Parameters ok' );\r
+} \r
use HTTP::Headers::Util 'split_header_words';
-
-my $expected = {
- Catalyst => [ qw( Catalyst Cool path / ) ],
- Cool => [ qw( Cool Catalyst path / ) ]
+my $expected = {
+ Catalyst => [qw( Catalyst Cool path / )],
+ Cool => [qw( Cool Catalyst path / )]
};
{
- ok( my $response = request('http://localhost/engine/response/cookies/one'), 'Request' );
+ ok( my $response = request('http://localhost/engine/response/cookies/one'),
+ 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/cookies/one', 'Test Action' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/one', 'Test Action' );
my $cookies = {};
}
{
- ok( my $response = request('http://localhost/engine/response/cookies/two'), 'Request' );
+ ok( my $response = request('http://localhost/engine/response/cookies/two'),
+ 'Request' );
ok( $response->is_redirect, 'Response Redirection 3xx' );
is( $response->code, 302, 'Response Code' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/cookies/two', 'Test Action' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/two', 'Test Action' );
my $cookies = {};
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 18;
+use Catalyst::Test 'TestApp';
+use HTTP::Request::Common;
+
+my $content_length;
+
+foreach my $method qw(HEAD GET) {
+ my $expected = join( ', ', 1 .. 10 );
+
+ my $request = HTTP::Request::Common->can($method)
+ ->( 'http://localhost/engine/response/headers/one' );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->code, 200, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/headers/one', 'Test Action' );
+ is( $response->header('X-Header-Catalyst'),
+ 'Cool', 'Response Header X-Header-Catalyst' );
+ is( $response->header('X-Header-Cool'),
+ 'Catalyst', 'Response Header X-Header-Cool' );
+ is( $response->header('X-Header-Numbers'),
+ $expected, 'Response Header X-Header-Numbers' );
+
+ use bytes;
+ if ( $method eq 'HEAD' ) {
+ $content_length = $response->header('Content-Length');
+ ok( $content_length > 0, 'Response Header Content-Length' );
+ is( length($response->content),
+ 0,
+ 'HEAD method content is empty' );
+ }
+ elsif ( $method eq 'GET' ) {
+ # method name is echo'd back in content-body, which
+ # accounts for difference in content length. In normal
+ # cases the Content-Length should be the same regardless
+ # of if its a GET or HEAD request.
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 2;
+ }
+ is( $response->header('Content-Length'),
+ $content_length - 1, 'Response Header Content-Length' );
+ is( length($response->content),
+ $response->header('Content-Length'),
+ 'GET method content' );
+ }
+ }
+}
--- /dev/null
+#!perl\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use FindBin;\r
+use lib "$FindBin::Bin/../../lib";\r
+\r
+use Test::More tests => 6;\r
+use Catalyst::Test 'TestApp';\r
+\r
+# phaylon noticed that refactored was truncating output on large images.\r
+# This test tests 100K and 1M output content.\r
+\r
+my $expected = {\r
+ one => 'x' x (100 * 1024),\r
+ two => 'y' x (1024 * 1024),\r
+};\r
+\r
+for my $action ( keys %{$expected} ) {\r
+ ok( my $response = request('http://localhost/engine/response/large/' . $action ),\r
+ 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ \r
+ is( length( $response->content ), length( $expected->{$action} ), 'Length OK' );\r
+}\r
+\r
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 1;
+ }
+ # Allow overriding automatic root.
+ is( TestApp->config->{root}, '/some/dir' );
+}
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 2;
+use Catalyst::Test 'TestApp';
+
+{
+ # Allow overriding automatic root.
+ ok( my $response = request('http://localhost/engine/response/headers/one'), 'Request' );
+ is( $response->header('X-Catalyst-Plugin-Setup'), '1' );
+}
--- /dev/null
+package Catalyst::Plugin::Test::Plugin;
+
+use strict;
+
+use base 'Class::Data::Inheritable';
+
+ __PACKAGE__->mk_classdata('ran_setup');
+
+sub setup {
+ my $c = shift;
+ $c->ran_setup('1');
+}
+
+sub prepare {
+
+ my $class = shift;
+
+ my $c = $class->NEXT::prepare(@_);
+ $c->response->header( 'X-Catalyst-Plugin-Setup' => $c->ran_setup );
+
+ return $c;
+
+}
+
+1;
package TestApp;
use strict;
-use Catalyst qw[Test::Errors Test::Headers];
+use Catalyst qw/Test::Errors Test::Headers Test::Plugin/;
use Catalyst::Utils;
our $VERSION = '0.01';
-TestApp->config(
- name => 'TestApp',
- root => '/Users/chansen/src/MyApp/root',
-);
+TestApp->config( name => 'TestApp', root => '/some/dir' );
TestApp->setup;
-#sub execute { return shift->NEXT::execute(@_); } # does not work, bug?
-
sub global_action : Private {
my ( $self, $c ) = @_;
$c->forward('TestApp::View::Dump::Request');
sub execute {
my $c = shift;
my $class = ref( $c->component( $_[0] ) ) || $_[0];
- my $action = $c->actions->{reverse}->{"$_[1]"} || "$_[1]";
+ my $action = "$_[1]";
my $method;
if ( $class && $method ) {
my $executed = sprintf( "%s->%s", $class, $method );
- $c->response->headers->push_header( 'X-Catalyst-Executed' => $executed );
+ my @executed = $c->response->headers->header('X-Catalyst-Executed');
+ push @executed, $executed;
+ $c->response->headers->header(
+ 'X-Catalyst-Executed' => join ', ',
+ @executed
+ );
}
-
+
return $c->SUPER::execute(@_);
}
sub begin : Private {
my ( $self, $c ) = @_;
- $c->res->header( 'X-Test-Class' => ref($self) );
+ $c->res->header( 'X-Test-Class' => ref($self) );
$c->response->content_type('text/plain; charset=utf-8');
}
--- /dev/null
+package TestApp::Controller::Action::Detach;\r
+\r
+use strict;\r
+use base 'TestApp::Controller::Action';\r
+\r
+sub one : Local {\r
+ my ( $self, $c ) = @_;\r
+ $c->detach('two');\r
+ $c->forward('error');\r
+}\r
+\r
+sub two : Private {\r
+ my ( $self, $c ) = @_;\r
+ $c->forward('TestApp::View::Dump::Request');\r
+}\r
+\r
+sub error : Local {\r
+ my ( $self, $c ) = @_;\r
+ $c->res->output('error');\r
+}\r
+\r
+sub path : Local {\r
+ my ( $self, $c ) = @_;\r
+ $c->detach('/action/detach/two');\r
+ $c->forward('error');\r
+}\r
+\r
+sub with_args : Local {\r
+ my ( $self, $c, $orig ) = @_;\r
+ $c->detach( 'args', [qq/new/] );\r
+}\r
+\r
+sub with_method_and_args : Local {\r
+ my ( $self, $c, $orig ) = @_;\r
+ $c->detach( qw/TestApp::Controller::Action::Detach args/, [qq/new/] );\r
+}\r
+\r
+sub args : Local {\r
+ my ( $self, $c, $val ) = @_;\r
+ die "Expected argument 'new', got '$val'" unless $val eq 'new';\r
+ die "passed argument does not match args" unless $val eq $c->req->args->[0];\r
+ $c->res->body( $c->req->args->[0] );\r
+}\r
+\r
+1;\r
use strict;
use base 'TestApp::Controller::Action';
-sub end : Private {
+sub end : Private {
my ( $self, $c ) = @_;
}
$c->forward('TestApp::View::Dump::Request');
}
-sub six : Local {
- my ( $self, $c ) = @_;
- $c->forward('TestApp::View::Dump::False');
-}
-
-
sub jojo : Local {
my ( $self, $c ) = @_;
$c->forward('one');
$c->forward('three');
}
-
sub inheritance : Local {
my ( $self, $c ) = @_;
$c->forward('/action/inheritance/a/b/default');
sub global : Local {
my ( $self, $c ) = @_;
- $c->forward( '/global_action' );
+ $c->forward('/global_action');
}
sub with_args : Local {
my ( $self, $c, $orig ) = @_;
- $c->forward( 'args',[qq/new/] );
+ $c->forward( 'args', [qq/new/] );
$c->res->body( $c->req->args->[0] );
}
--- /dev/null
+package TestApp::Controller::Action::Streaming;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub streaming : Global {
+ my ( $self, $c ) = @_;
+ for my $line ( split "\n", <<'EOF' ) {
+foo
+bar
+baz
+EOF
+ $c->res->write("$line\n");
+ }
+}
+
+1;
--- /dev/null
+package TestApp::Controller::Engine::Request::URI;\r
+\r
+use strict;\r
+use base 'Catalyst::Base';\r
+\r
+sub default : Private {\r
+ my ( $self, $c ) = @_;\r
+ \r
+ $c->forward('TestApp::View::Dump::Request');\r
+}\r
+\r
+sub change_path : Local {\r
+ my ( $self, $c ) = @_;\r
+ \r
+ # change the path\r
+ $c->req->path( '/my/app/lives/here' );\r
+ \r
+ $c->forward('TestApp::View::Dump::Request');\r
+}\r
+\r
+sub change_base : Local {\r
+ my ( $self, $c ) = @_;\r
+ \r
+ # change the base and uri paths\r
+ $c->req->base->path( '/new/location' );\r
+ $c->req->uri->path( '/new/location/engine/request/uri/change_base' );\r
+ \r
+ $c->forward('TestApp::View::Dump::Request');\r
+}\r
+\r
+1;\r
sub one : Relative {
my ( $self, $c ) = @_;
- $c->res->header( 'X-Header-Catalyst' => 'Cool' );
- $c->res->header( 'X-Header-Cool' => 'Catalyst' );
- $c->res->header( 'X-Header-Numbers' => [ 1 .. 10 ] );
+ $c->res->header( 'X-Header-Catalyst' => 'Cool' );
+ $c->res->header( 'X-Header-Cool' => 'Catalyst' );
+ $c->res->header( 'X-Header-Numbers' => join ', ', 1 .. 10 );
$c->forward('TestApp::View::Dump::Request');
}
--- /dev/null
+package TestApp::Controller::Engine::Response::Large;\r
+\r
+use strict;\r
+use base 'Catalyst::Base';\r
+\r
+sub one : Relative {\r
+ my ( $self, $c ) = @_;\r
+ $c->res->output( 'x' x (100 * 1024) ); \r
+}\r
+\r
+sub two : Relative {\r
+ my ( $self, $c ) = @_;\r
+ $c->res->output( 'y' x (1024 * 1024) );\r
+}\r
+\r
+1;\r
--- /dev/null
+package TestApp::View::Dump;
+
+use strict;
+use base 'Catalyst::Base';
+
+use Data::Dumper ();
+
+sub dump {
+ my ( $self, $reference ) = @_;
+
+ return unless $reference;
+
+ my $dumper = Data::Dumper->new( [$reference] );
+ $dumper->Indent(1);
+ $dumper->Purity(1);
+ $dumper->Useqq(0);
+ $dumper->Deepcopy(1);
+ $dumper->Quotekeys(0);
+ $dumper->Terse(1);
+
+ return $dumper->Dump;
+}
+
+sub process {
+ my ( $self, $c, $reference ) = @_;
+
+ # Force processing of on-demand data
+ $c->prepare_body;
+
+ # Remove context from reference if needed
+ my $context = delete $reference->{_context};
+
+ # Remove body from reference if needed
+ my $body = delete $reference->{_body};
+
+ if ( my $output =
+ $self->dump( $reference || $c->stash->{dump} || $c->stash ) )
+ {
+
+ $c->res->headers->content_type('text/plain');
+ $c->res->output($output);
+
+ # Repair context
+ $reference->{_context} = $context;
+
+ # Repair body
+ $reference->{_body} = $body;
+
+ return 1;
+ }
+
+ return 0;
+}
+
+1;
package TestApp::View::Dump::Parameters;
use strict;
-use base qw[TestApp::View::Dump];
+use base 'TestApp::View::Dump';
sub process {
my ( $self, $c ) = @_;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Test::More tests => 5;
+use Catalyst::Test 'TestApp';
+
+my @expected = qw[
+ Catalyst::Plugin::Test::Errors
+ Catalyst::Plugin::Test::Headers
+ Catalyst::Plugin::Test::Plugin
+];
+
+my $expected = join( ", ", @expected );
+
+ok( my $response = request('http://localhost/dump/request'), 'Request' );
+ok( $response->is_success, 'Response Successful 2xx' );
+is( $response->content_type, 'text/plain', 'Response Content-Type' );
+like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+is( $response->header('X-Catalyst-Plugins'), $expected, 'Loaded plugins' );
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/../lib";
-
-use Test::More tests => 5;
-use Catalyst::Test 'TestApp';
-
-
-{
- my @expected = qw[
- Catalyst::Plugin::Test::Errors
- Catalyst::Plugin::Test::Headers
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/dump/request'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
- is( $response->header('X-Catalyst-Plugins'), $expected, 'Loaded plugins' );
-}
--- /dev/null
+use Test::More tests => 7;
+use strict;
+use warnings;
+
+use_ok('Catalyst');
+
+my @complist = map { "MyApp::$_"; } qw/C::Controller M::Model V::View/;
+
+{
+ package MyApp;
+
+ use base qw/Catalyst/;
+
+ __PACKAGE__->components({ map { ($_, $_) } @complist });
+}
+
+is(MyApp->comp('MyApp::V::View'), 'MyApp::V::View', 'Explicit return ok');
+
+is(MyApp->comp('C::Controller'), 'MyApp::C::Controller', 'Two-part return ok');
+
+is(MyApp->comp('Model'), 'MyApp::M::Model', 'Single part return ok');
+
+is(MyApp->comp('::M::'), 'MyApp::M::Model', 'Regex return ok');
+
+is_deeply([ MyApp->comp() ], \@complist, 'Empty return ok');
+
+is_deeply([ MyApp->comp('Foo') ], \@complist, 'Fallthrough return ok');
+ # Is this desired behaviour?
--- /dev/null
+#!perl\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use FindBin;\r
+use lib "$FindBin::Bin/../../live/lib";\r
+\r
+use Test::More;\r
+use Catalyst::Test 'TestApp';\r
+use Catalyst::Request;\r
+use Config;\r
+\r
+if ( $Config{useithreads} && !$ENV{CATALYST_SERVER} ) {\r
+ require threads;\r
+ plan tests => 3;\r
+}\r
+else {\r
+ if ( $ENV{CATALYST_SERVER} ) {\r
+ plan skip_all => 'Using remote server';\r
+ }\r
+ else {\r
+ plan skip_all => 'Needs a Perl with ithreads enabled';\r
+ }\r
+}\r
+ \r
+no warnings 'redefine';\r
+sub request {\r
+ my $thr = threads->new( \r
+ sub { TestApp->run(@_) },\r
+ @_ \r
+ );\r
+ $thr->join;\r
+}\r
+\r
+# test that running inside a thread works ok\r
+{\r
+ my @expected = qw[\r
+ TestApp::Controller::Action::Default->begin\r
+ TestApp::Controller::Action::Default->default\r
+ TestApp::View::Dump::Request->process\r
+ ];\r
+\r
+ my $expected = join( ", ", @expected );\r
+ \r
+ ok( my $response = request('http://localhost/action/default'), 'Request' );\r
+ ok( $response->is_success, 'Response Successful 2xx' );\r
+ is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' );\r
+}\r
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::MockObject;
+use URI;
+
+my $request = Test::MockObject->new;
+$request->mock( 'base', sub { URI->new('http://127.0.0.1/foo') } );
+$request->mock( 'match', sub { '/yada' } );
+
+my $context = Test::MockObject->new;
+$context->mock( 'request', sub { $request } );
+
+use_ok('Catalyst');
+
+is(
+ Catalyst::uri_for( $context, '/bar/baz' )->as_string,
+ 'http://127.0.0.1/foo/bar/baz',
+ 'URI for absolute path'
+);
+
+is(
+ Catalyst::uri_for( $context, 'bar/baz' )->as_string,
+ 'http://127.0.0.1/foo/yada/bar/baz',
+ 'URI for relative path'
+);
+
+is( Catalyst::uri_for( $context, '../quux' )->as_string,
+ 'http://127.0.0.1/foo/quux', 'URI for relative dot path' );
projects / catagits/Catalyst-Runtime.git / commitdiff