From: Andy Grundman Date: Mon, 10 Oct 2005 19:03:41 +0000 (+0000) Subject: Merged 5.49_01 (r1339) from refactored branch to trunk X-Git-Tag: 5.7099_04~1232 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=fbcc39ad23f2bbecf5d84c9ba581e6af86fcd460 Merged 5.49_01 (r1339) from refactored branch to trunk --- diff --git a/Build.PL b/Build.PL index 0f8b5f9..40a7891 100644 --- a/Build.PL +++ b/Build.PL @@ -2,41 +2,49 @@ use strict; 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" @@ -45,3 +53,9 @@ print( '*' x 80, "\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. +/; diff --git a/Changes b/Changes index 126efae..c90e652 100644 --- a/Changes +++ b/Changes @@ -1,12 +1,45 @@ -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. diff --git a/MANIFEST b/MANIFEST index 12f94be..fe278f6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,32 +1,14 @@ 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 @@ -44,7 +26,6 @@ lib/Catalyst/Manual/WritingPlugins.pod 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 @@ -55,52 +36,63 @@ script/catalyst.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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..2ffcc10 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,25 @@ +# 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\.# diff --git a/META.yml b/META.yml index a4b233a..b7c62e0 100644 --- a/META.yml +++ b/META.yml @@ -1,34 +1,41 @@ --- name: Catalyst -version: 5.33 +version: 5.49_01 author: - 'Sebastian Riedel, C' 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: @@ -37,54 +44,12 @@ provides: 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: @@ -102,10 +67,8 @@ provides: 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 diff --git a/README b/README index 58c0b27..8ead33a 100644 --- a/README +++ b/README @@ -72,21 +72,75 @@ DESCRIPTION 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 @@ -106,6 +160,154 @@ METHODS $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". @@ -114,8 +316,55 @@ CASE SENSITIVITY 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: @@ -142,10 +391,14 @@ SEE ALSO CREDITS Andy Grundman + Andy Wardley + Andrew Ford Andrew Ruthven + Arthur Bergman + Autrijus Tang Christian Hansen @@ -164,6 +417,8 @@ CREDITS Jesse Sheidlower + Jesse Vincent + Jody Belka Johan Lindstrom @@ -178,8 +433,6 @@ CREDITS Robert Sedlacek - Sebastian Riedel - Tatsuhiko Miyagawa Ulf Edvinsson diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index bf3049b..4ee787e 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -1,19 +1,65 @@ 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 @@ -96,6 +142,10 @@ this is equivalent to: use Catalyst; sub debug { 1 } +=item -Dispatcher + +Force Catalyst to use a specific dispatcher. + =item -Engine Force Catalyst to use a specific engine. @@ -103,12 +153,66 @@ Omit the C prefix of the engine name, i.e.: 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. @@ -117,33 +221,214 @@ Overload to enable debug messages. sub debug { 0 } -=item config +=item $c->detach( $command [, \@arguments ] ) -Returns a hashref containing your applications settings. +Like C 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 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 @@ -173,8 +458,7 @@ sub plugin { 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 }; @@ -182,10 +466,9 @@ sub plugin { 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); @@ -193,6 +476,874 @@ sub plugin { if $class->debug; } +=item $c->request + +=item $c->req + +Returns a C object. + + my $req = $c->req; + +=item $c->response + +=item $c->res + +Returns a C 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 @@ -204,9 +1355,56 @@ But you can activate case sensitivity with a config parameter. MyApp->config->{case_sensitive} = 1; -=head1 LIMITATIONS +So C becomes C. + +=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 @@ -245,10 +1443,14 @@ Web: Andy Grundman +Andy Wardley + Andrew Ford Andrew Ruthven +Arthur Bergman + Autrijus Tang Christian Hansen @@ -267,6 +1469,8 @@ Geoff Richards Jesse Sheidlower +Jesse Vincent + Jody Belka Johan Lindstrom @@ -281,8 +1485,6 @@ Matt S Trout Robert Sedlacek -Sebastian Riedel - Tatsuhiko Miyagawa Ulf Edvinsson diff --git a/lib/Catalyst/Action.pm b/lib/Catalyst/Action.pm new file mode 100644 index 0000000..581d03c --- /dev/null +++ b/lib/Catalyst/Action.pm @@ -0,0 +1,69 @@ +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. + +=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; diff --git a/lib/Catalyst/Dispatcher.pm b/lib/Catalyst/Dispatcher.pm index cb01934..eb4662c 100644 --- a/lib/Catalyst/Dispatcher.pm +++ b/lib/Catalyst/Dispatcher.pm @@ -1,14 +1,18 @@ 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 @@ -24,27 +28,22 @@ See L. =over 4 -=item $c->detach( $command [, \@arguments ] ) - -Like C 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 } ) || '/' ) @@ -52,7 +51,8 @@ sub dispatch { 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} ); } } @@ -63,37 +63,46 @@ sub dispatch { 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"/ @@ -103,22 +112,12 @@ sub dispatch { } } -=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; @@ -128,16 +127,32 @@ sub forward { } # 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/^\///; } @@ -145,13 +160,12 @@ sub forward { $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); @@ -163,9 +177,17 @@ qq/Couldn't forward to command "$command". Invalid action or component./; 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); @@ -179,7 +201,7 @@ qq/Couldn't forward to command "$command". Invalid action or component./; 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; } @@ -187,35 +209,83 @@ qq/Couldn't forward to command "$command". Invalid action or component./; 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; @@ -235,14 +305,14 @@ sub get_action { $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; } @@ -250,17 +320,18 @@ sub get_action { 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 ] ]; } } @@ -268,14 +339,12 @@ sub get_action { 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} ) @@ -301,7 +370,7 @@ sub set_action { } return unless keys %flags; - my $parent = $c->tree; + my $parent = $self->tree; my $visitor = Tree::Simple::Visitor::FindByPath->new; for my $part ( split '/', $prefix ) { @@ -319,10 +388,21 @@ sub set_action { $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+$//; @@ -337,8 +417,6 @@ sub set_action { 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; @@ -350,25 +428,21 @@ sub set_action { $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( @@ -376,15 +450,14 @@ sub setup_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'); @@ -412,7 +485,7 @@ sub setup_actions { if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) { $name = *{$sym}{NAME}; - $self->set_action( $name, $code, $comp, $attrs ); + $class->set_action( $name, $code, $comp, $attrs ); last; } @@ -424,7 +497,7 @@ sub setup_actions { } - return unless $self->debug; + return unless $class->debug; my $actions = $self->actions; my $privates = Text::ASCIITable->new; @@ -439,15 +512,15 @@ sub setup_actions { 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; @@ -456,13 +529,11 @@ sub setup_actions { $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; @@ -471,13 +542,11 @@ sub setup_actions { $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} } ); } diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index de7e082..f378d57 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -1,36 +1,18 @@ 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 @@ -46,216 +28,32 @@ See L. =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 , 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}, @@ -265,18 +63,20 @@ sub finalize_cookies { -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'; @@ -291,6 +91,17 @@ sub finalize_error { @{ $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; @@ -316,7 +127,7 @@ sub finalize_error { (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 $name = ''; @@ -383,329 +194,263 @@ sub finalize_error { } -=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 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 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, -Sebastian Riedel, C +Andy Grundman, =head1 COPYRIGHT diff --git a/lib/Catalyst/Engine/Apache.pm b/lib/Catalyst/Engine/Apache.pm deleted file mode 100644 index 2e0f374..0000000 --- a/lib/Catalyst/Engine/Apache.pm +++ /dev/null @@ -1,49 +0,0 @@ -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. - -=head1 DESCRIPTION - -This class will load the correct MP Engine. - -=head1 SEE ALSO - -L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Engine/Apache/Base.pm b/lib/Catalyst/Engine/Apache/Base.pm deleted file mode 100644 index ebb3148..0000000 --- a/lib/Catalyst/Engine/Apache/Base.pm +++ /dev/null @@ -1,193 +0,0 @@ -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. - -=head1 DESCRIPTION - -This is a base class for Apache Engines. - -=head1 METHODS - -=over 4 - -=item $c->apache - -Returns an C object. - -=back - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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 directive, -# not 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 L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP13.pm b/lib/Catalyst/Engine/Apache/MP13.pm deleted file mode 100644 index b0a7d1c..0000000 --- a/lib/Catalyst/Engine/Apache/MP13.pm +++ /dev/null @@ -1,95 +0,0 @@ -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. - -=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 -and C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP13/Apreq.pm b/lib/Catalyst/Engine/Apache/MP13/Apreq.pm deleted file mode 100644 index d428233..0000000 --- a/lib/Catalyst/Engine/Apache/MP13/Apreq.pm +++ /dev/null @@ -1,95 +0,0 @@ -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. - -=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. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP13/Base.pm b/lib/Catalyst/Engine/Apache/MP13/Base.pm deleted file mode 100644 index e22e408..0000000 --- a/lib/Catalyst/Engine/Apache/MP13/Base.pm +++ /dev/null @@ -1,89 +0,0 @@ -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. - -=head1 DESCRIPTION - -This is a base class for MP 1.3 Engines. - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP19.pm b/lib/Catalyst/Engine/Apache/MP19.pm deleted file mode 100644 index a3e2da3..0000000 --- a/lib/Catalyst/Engine/Apache/MP19.pm +++ /dev/null @@ -1,95 +0,0 @@ -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. - -=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 -and C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP19/Apreq.pm b/lib/Catalyst/Engine/Apache/MP19/Apreq.pm deleted file mode 100644 index 3c98df4..0000000 --- a/lib/Catalyst/Engine/Apache/MP19/Apreq.pm +++ /dev/null @@ -1,102 +0,0 @@ -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. - -=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. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP19/Base.pm b/lib/Catalyst/Engine/Apache/MP19/Base.pm deleted file mode 100644 index 9680724..0000000 --- a/lib/Catalyst/Engine/Apache/MP19/Base.pm +++ /dev/null @@ -1,91 +0,0 @@ -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. - -=head1 DESCRIPTION - -This is a base class for MP 1.99 Engines. - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP20.pm b/lib/Catalyst/Engine/Apache/MP20.pm deleted file mode 100644 index b20fea8..0000000 --- a/lib/Catalyst/Engine/Apache/MP20.pm +++ /dev/null @@ -1,95 +0,0 @@ -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. - -=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 -and C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP20/Apreq.pm b/lib/Catalyst/Engine/Apache/MP20/Apreq.pm deleted file mode 100644 index 4716d7a..0000000 --- a/lib/Catalyst/Engine/Apache/MP20/Apreq.pm +++ /dev/null @@ -1,102 +0,0 @@ -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. - -=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. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Apache/MP20/Base.pm b/lib/Catalyst/Engine/Apache/MP20/Base.pm deleted file mode 100644 index a719b95..0000000 --- a/lib/Catalyst/Engine/Apache/MP20/Base.pm +++ /dev/null @@ -1,90 +0,0 @@ -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. - -=head1 DESCRIPTION - -This is a base class for MP 2.0 Engines. - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/CGI.pm b/lib/Catalyst/Engine/CGI.pm index 11d8ebf..82ea2ca 100644 --- a/lib/Catalyst/Engine/CGI.pm +++ b/lib/Catalyst/Engine/CGI.pm @@ -1,28 +1,10 @@ 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 @@ -45,153 +27,179 @@ appropriate engine module. =head1 DESCRIPTION -This is the Catalyst engine specialized for the CGI environment (using the -C and C modules). - -=head1 METHODS - -=over 4 - -=item $c->cgi - -Contains the C object. - -=back +This is the Catalyst engine specialized for the CGI environment. =head1 OVERLOADED METHODS -This class overloads some methods from C. +This class overloads some methods from C. =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 L L. +L L. + +=head1 AUTHORS + +Sebastian Riedel, -=head1 AUTHOR +Christian Hansen, -Sebastian Riedel, C -Christian Hansen, C +Andy Grundman, =head1 COPYRIGHT diff --git a/lib/Catalyst/Engine/CGI/APR.pm b/lib/Catalyst/Engine/CGI/APR.pm deleted file mode 100644 index 81cfb6a..0000000 --- a/lib/Catalyst/Engine/CGI/APR.pm +++ /dev/null @@ -1,139 +0,0 @@ -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 for parsing of message body. - -=head1 METHODS - -=over 4 - -=item $c->apr - -Contains the C object. - -=item $c->pool - -Contains the C object. - -=back - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/CGI/Base.pm b/lib/Catalyst/Engine/CGI/Base.pm deleted file mode 100644 index 6e19c60..0000000 --- a/lib/Catalyst/Engine/CGI/Base.pm +++ /dev/null @@ -1,163 +0,0 @@ -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. - -=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. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/FastCGI.pm b/lib/Catalyst/Engine/FastCGI.pm index 506927b..9f31da1 100644 --- a/lib/Catalyst/Engine/FastCGI.pm +++ b/lib/Catalyst/Engine/FastCGI.pm @@ -1,84 +1,67 @@ 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 -and C. +This class overloads some methods from C. =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, L. -=head1 SEE ALSO +=head1 AUTHORS -L, L, L. +Sebastian Riedel, -=head1 AUTHOR +Christian Hansen, -Sebastian Riedel, C -Christian Hansen, C +Andy Grundman, =head1 COPYRIGHT diff --git a/lib/Catalyst/Engine/FastCGI/APR.pm b/lib/Catalyst/Engine/FastCGI/APR.pm deleted file mode 100644 index 01e5877..0000000 --- a/lib/Catalyst/Engine/FastCGI/APR.pm +++ /dev/null @@ -1,88 +0,0 @@ -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. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/FastCGI/Base.pm b/lib/Catalyst/Engine/FastCGI/Base.pm deleted file mode 100644 index a2650b8..0000000 --- a/lib/Catalyst/Engine/FastCGI/Base.pm +++ /dev/null @@ -1,75 +0,0 @@ -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 object. - -=back - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 4ec9fb3..27873f2 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -1,7 +1,11 @@ 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 @@ -25,14 +29,228 @@ A script using the Catalyst::Engine::HTTP module might look like: 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, L, L. +L, L. + +=head1 AUTHORS + +Sebastian Riedel, + +Dan Kubb, -=head1 AUTHOR +=head1 THANKS -Sebastian Riedel, C -Christian Hansen, C +Many parts are ripped out of C by Jesse Vincent. =head1 COPYRIGHT diff --git a/lib/Catalyst/Engine/HTTP/Base.pm b/lib/Catalyst/Engine/HTTP/Base.pm deleted file mode 100644 index ba512f1..0000000 --- a/lib/Catalyst/Engine/HTTP/Base.pm +++ /dev/null @@ -1,217 +0,0 @@ -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. - -=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. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/HTTP/Daemon.pm b/lib/Catalyst/Engine/HTTP/Daemon.pm deleted file mode 100644 index 00daf22..0000000 --- a/lib/Catalyst/Engine/HTTP/Daemon.pm +++ /dev/null @@ -1,310 +0,0 @@ -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. - -=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, L, L, -L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=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; diff --git a/lib/Catalyst/Engine/SpeedyCGI.pm b/lib/Catalyst/Engine/SpeedyCGI.pm deleted file mode 100644 index b833450..0000000 --- a/lib/Catalyst/Engine/SpeedyCGI.pm +++ /dev/null @@ -1,90 +0,0 @@ -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 -and C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/SpeedyCGI/Base.pm b/lib/Catalyst/Engine/SpeedyCGI/Base.pm deleted file mode 100644 index 6c89c4c..0000000 --- a/lib/Catalyst/Engine/SpeedyCGI/Base.pm +++ /dev/null @@ -1,70 +0,0 @@ -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 object. - -=back - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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, L, L. - -=head1 AUTHOR - -Sebastian Riedel, C -Christian Hansen, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/Test.pm b/lib/Catalyst/Engine/Test.pm index a5f9ca4..fb487a1 100644 --- a/lib/Catalyst/Engine/Test.pm +++ b/lib/Catalyst/Engine/Test.pm @@ -1,9 +1,11 @@ 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 @@ -31,47 +33,102 @@ This is the Catalyst engine specialized for testing. =head1 OVERLOADED METHODS -This class overloads some methods from C. +This class overloads some methods from C. =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. -=head1 AUTHOR +=head1 AUTHORS + +Sebastian Riedel, + +Christian Hansen, -Sebastian Riedel, C -Christian Hansen, C +Andy Grundman, =head1 COPYRIGHT diff --git a/lib/Catalyst/Helper.pm b/lib/Catalyst/Helper.pm index 1d25105..d556068 100644 --- a/lib/Catalyst/Helper.pm +++ b/lib/Catalyst/Helper.pm @@ -103,13 +103,12 @@ sub mk_component { 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 ); } @@ -152,13 +151,12 @@ sub mk_component { $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 ); } @@ -195,10 +193,8 @@ sub mk_dir { 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 @@ -212,21 +208,19 @@ sub 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 @@ -243,7 +237,7 @@ sub next_test { $prefix = $prefix; $tname = $prefix . '.t'; $self->{prefix} = $prefix; - $prefix = lc $prefix; + $prefix = lc $prefix; $prefix =~ s/-/\//g; $self->{uri} = $prefix; } @@ -266,7 +260,9 @@ sub render_file { 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 ); } @@ -465,14 +461,27 @@ Catalyst based application. 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 @@ -644,14 +653,21 @@ use FindBin; 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; @@ -664,7 +680,9 @@ pod2usage(1) if $help; [% 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: @@ -838,7 +856,9 @@ Catalyst component. 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 diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm index a8b9869..3aaa6af 100644 --- a/lib/Catalyst/Request.pm +++ b/lib/Catalyst/Request.pm @@ -6,20 +6,23 @@ use base 'Class::Accessor::Fast'; 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 @@ -35,12 +38,13 @@ Catalyst::Request - Catalyst Request Class $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; @@ -52,6 +56,8 @@ Catalyst::Request - Catalyst Request Class $req->parameters; $req->path; $req->protocol; + $req->query_parameters; + $req->read; $req->referer; $req->secure; $req->snippets; @@ -107,6 +113,35 @@ C or C. 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 @@ -142,7 +177,7 @@ sub cookie { unless ( exists $self->cookies->{$name} ) { return undef; } - + return $self->cookies->{$name}; } } @@ -153,30 +188,9 @@ Returns a reference to a hash containing the cookies. 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 @@ -200,7 +214,8 @@ sub hostname { 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 ) { @@ -268,7 +283,7 @@ sub param { if ( @_ > 1 ) { while ( my ( $field, $value ) = splice( @_, 0, 2 ) ) { - + next unless defined $field; if ( exists $self->parameters->{$field} ) { @@ -296,16 +311,69 @@ be either a scalar or an arrayref containing scalars. 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 + +=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. @@ -356,8 +424,8 @@ sub upload { } else { return (wantarray) - ? ( $self->uploads->{$upload} ) - : $self->uploads->{$upload}; + ? ( $self->uploads->{$upload} ) + : $self->uploads->{$upload}; } } @@ -386,18 +454,19 @@ hashref or a arrayref containing C objects. 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. diff --git a/lib/Catalyst/Response.pm b/lib/Catalyst/Response.pm index e0d1a3b..6f8b5c6 100644 --- a/lib/Catalyst/Response.pm +++ b/lib/Catalyst/Response.pm @@ -8,9 +8,9 @@ __PACKAGE__->mk_accessors(qw/cookies body headers location status/); *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 @@ -18,17 +18,19 @@ Catalyst::Response - Catalyst Response Class =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. @@ -41,45 +43,67 @@ to response data. =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 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. @@ -90,8 +114,8 @@ Contains a location to redirect to. sub redirect { my $self = shift; - - if ( @_ ) { + + if (@_) { my $location = shift; my $status = shift || 302; @@ -102,11 +126,19 @@ sub redirect { 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 diff --git a/t/TODO b/t/TODO deleted file mode 100644 index ab8e998..0000000 --- a/t/TODO +++ /dev/null @@ -1,42 +0,0 @@ - [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 diff --git a/t/component/controller/action/begin.t b/t/component/controller/action/begin.t deleted file mode 100644 index ede5d34..0000000 --- a/t/component/controller/action/begin.t +++ /dev/null @@ -1,29 +0,0 @@ -#!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' ); -} diff --git a/t/engine/request/headers.t b/t/engine/request/headers.t deleted file mode 100644 index 3f0393b..0000000 --- a/t/engine/request/headers.t +++ /dev/null @@ -1,37 +0,0 @@ -#!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' ); -} diff --git a/t/engine/response/headers.t b/t/engine/response/headers.t deleted file mode 100644 index dd835db..0000000 --- a/t/engine/response/headers.t +++ /dev/null @@ -1,23 +0,0 @@ -#!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' ); -} diff --git a/t/engine/setup/basics.t b/t/engine/setup/basics.t deleted file mode 100644 index 5a27671..0000000 --- a/t/engine/setup/basics.t +++ /dev/null @@ -1,15 +0,0 @@ -#!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'); -} diff --git a/t/lib/TestApp/View/Dump.pm b/t/lib/TestApp/View/Dump.pm deleted file mode 100644 index 9e0aa63..0000000 --- a/t/lib/TestApp/View/Dump.pm +++ /dev/null @@ -1,37 +0,0 @@ -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; diff --git a/t/lib/TestApp/View/Dump/False.pm b/t/lib/TestApp/View/Dump/False.pm deleted file mode 100644 index 014337b..0000000 --- a/t/lib/TestApp/View/Dump/False.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestApp::View::Dump::False; - -use strict; -use base qw[TestApp::View::Dump::Request]; -use overload - '""' => sub { undef; }; - -1; diff --git a/t/live/component/controller/action/begin.t b/t/live/component/controller/action/begin.t new file mode 100644 index 0000000..f94d13b --- /dev/null +++ b/t/live/component/controller/action/begin.t @@ -0,0 +1,34 @@ +#!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' ); +} diff --git a/t/component/controller/action/default.t b/t/live/component/controller/action/default.t similarity index 100% rename from t/component/controller/action/default.t rename to t/live/component/controller/action/default.t diff --git a/t/live/component/controller/action/detach.t b/t/live/component/controller/action/detach.t new file mode 100644 index 0000000..f33ee7a --- /dev/null +++ b/t/live/component/controller/action/detach.t @@ -0,0 +1,61 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../../../lib"; + +use Test::More tests => 18; +use Catalyst::Test 'TestApp'; + + +{ + my @expected = qw[ + TestApp::Controller::Action::Detach->begin + TestApp::Controller::Action::Detach->one + TestApp::Controller::Action::Detach->two + TestApp::View::Dump::Request->process + ]; + + my $expected = join( ", ", @expected ); + + # Test detach to chain of actions. + ok( my $response = request('http://localhost/action/detach/one'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + is( $response->content_type, 'text/plain', 'Response Content-Type' ); + is( $response->header('X-Catalyst-Action'), 'action/detach/one', 'Test Action' ); + is( $response->header('X-Test-Class'), 'TestApp::Controller::Action::Detach', 'Test Class' ); + is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' ); +} + +{ + my @expected = qw[ + TestApp::Controller::Action::Detach->begin + TestApp::Controller::Action::Detach->path + TestApp::Controller::Action::Detach->two + TestApp::View::Dump::Request->process + ]; + + my $expected = join( ", ", @expected ); + + # Test detach to chain of actions. + ok( my $response = request('http://localhost/action/detach/path'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + is( $response->content_type, 'text/plain', 'Response Content-Type' ); + is( $response->header('X-Catalyst-Action'), 'action/detach/path', 'Test Action' ); + is( $response->header('X-Test-Class'), 'TestApp::Controller::Action::Detach', 'Test Class' ); + is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' ); +} + +{ + ok( my $response = request('http://localhost/action/detach/with_args/old'), 'Request with args' ); + ok( $response->is_success, 'Response Successful 2xx' ); + is( $response->content, 'new'); +} + +{ + ok( my $response = request('http://localhost/action/detach/with_method_and_args/old'), 'Request with args and method' ); + ok( $response->is_success, 'Response Successful 2xx' ); + is( $response->content, 'new'); +} diff --git a/t/component/controller/action/end.t b/t/live/component/controller/action/end.t similarity index 100% rename from t/component/controller/action/end.t rename to t/live/component/controller/action/end.t diff --git a/t/component/controller/action/forward.t b/t/live/component/controller/action/forward.t similarity index 79% rename from t/component/controller/action/forward.t rename to t/live/component/controller/action/forward.t index fe2bd3a..58355af 100644 --- a/t/component/controller/action/forward.t +++ b/t/live/component/controller/action/forward.t @@ -6,7 +6,7 @@ use warnings; use FindBin; use lib "$FindBin::Bin/../../../lib"; -use Test::More tests => 31; +use Test::More tests => 24; use Catalyst::Test 'TestApp'; @@ -41,24 +41,6 @@ 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 diff --git a/t/component/controller/action/global.t b/t/live/component/controller/action/global.t similarity index 100% rename from t/component/controller/action/global.t rename to t/live/component/controller/action/global.t diff --git a/t/component/controller/action/inheritance.t b/t/live/component/controller/action/inheritance.t similarity index 100% rename from t/component/controller/action/inheritance.t rename to t/live/component/controller/action/inheritance.t diff --git a/t/component/controller/action/local.t b/t/live/component/controller/action/local.t similarity index 100% rename from t/component/controller/action/local.t rename to t/live/component/controller/action/local.t diff --git a/t/component/controller/action/path.t b/t/live/component/controller/action/path.t similarity index 100% rename from t/component/controller/action/path.t rename to t/live/component/controller/action/path.t diff --git a/t/component/controller/action/private.t b/t/live/component/controller/action/private.t similarity index 100% rename from t/component/controller/action/private.t rename to t/live/component/controller/action/private.t diff --git a/t/component/controller/action/regexp.t b/t/live/component/controller/action/regexp.t similarity index 100% rename from t/component/controller/action/regexp.t rename to t/live/component/controller/action/regexp.t diff --git a/t/live/component/controller/action/streaming.t b/t/live/component/controller/action/streaming.t new file mode 100644 index 0000000..46d42b2 --- /dev/null +++ b/t/live/component/controller/action/streaming.t @@ -0,0 +1,21 @@ +#!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 +} diff --git a/t/engine/request/body.t b/t/live/engine/request/body.t similarity index 51% rename from t/engine/request/body.t rename to t/live/engine/request/body.t index 3bc28fd..d2551f1 100644 --- a/t/engine/request/body.t +++ b/t/live/engine/request/body.t @@ -6,7 +6,7 @@ use warnings; use FindBin; use lib "$FindBin::Bin/../../lib"; -use Test::More tests => 20; +use Test::More tests => 18; use Catalyst::Test 'TestApp'; use Catalyst::Request; @@ -16,7 +16,8 @@ use HTTP::Request::Common; { my $creq; - my $request = POST( 'http://localhost/dump/request/', + my $request = POST( + 'http://localhost/dump/request/', 'Content-Type' => 'text/plain', 'Content' => 'Hello Catalyst' ); @@ -24,24 +25,29 @@ use HTTP::Request::Common; 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 ); @@ -49,16 +55,23 @@ use HTTP::Request::Common; 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' ); +} diff --git a/t/engine/request/cookies.t b/t/live/engine/request/cookies.t similarity index 77% rename from t/engine/request/cookies.t rename to t/live/engine/request/cookies.t index fc6401c..01faaac 100644 --- a/t/engine/request/cookies.t +++ b/t/live/engine/request/cookies.t @@ -18,25 +18,24 @@ use URI; { 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} }; diff --git a/t/live/engine/request/headers.t b/t/live/engine/request/headers.t new file mode 100644 index 0000000..9125e53 --- /dev/null +++ b/t/live/engine/request/headers.t @@ -0,0 +1,62 @@ +#!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' ); + } +} diff --git a/t/engine/request/parameters.t b/t/live/engine/request/parameters.t similarity index 51% rename from t/engine/request/parameters.t rename to t/live/engine/request/parameters.t index 68fb7cd..f399b78 100644 --- a/t/engine/request/parameters.t +++ b/t/live/engine/request/parameters.t @@ -6,7 +6,7 @@ use warnings; use FindBin; use lib "$FindBin::Bin/../../lib"; -use Test::More tests => 19; +use Test::More tests => 28; use Catalyst::Test 'TestApp'; use Catalyst::Request; @@ -17,63 +17,63 @@ use URI; { 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; @@ -88,5 +88,28 @@ __END__ 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' ); } diff --git a/t/engine/request/uploads.t b/t/live/engine/request/uploads.t similarity index 52% rename from t/engine/request/uploads.t rename to t/live/engine/request/uploads.t index f24b60b..fa753c1 100644 --- a/t/engine/request/uploads.t +++ b/t/live/engine/request/uploads.t @@ -6,7 +6,7 @@ use warnings; use FindBin; use lib "$FindBin::Bin/../../lib"; -use Test::More tests => 43; +use Test::More tests => 49; use Catalyst::Test 'TestApp'; use Catalyst::Request; @@ -18,100 +18,123 @@ use HTTP::Request::Common; { 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' ); } diff --git a/t/live/engine/request/uri.t b/t/live/engine/request/uri.t new file mode 100644 index 0000000..a6c6b38 --- /dev/null +++ b/t/live/engine/request/uri.t @@ -0,0 +1,52 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../../lib"; + +use Test::More tests => 18; +use Catalyst::Test 'TestApp'; +use Catalyst::Request; + +my $creq; + +# test that the path can be changed +{ + ok( my $response = request('http://localhost/engine/request/uri/change_path'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); + like( $creq->uri, qr{/my/app/lives/here}, 'URI contains new path' ); +} + +# test that path properly removes the base location +{ + ok( my $response = request('http://localhost/engine/request/uri/change_base'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); + like( $creq->base, qr{/new/location}, 'Base URI contains new location' ); + is( $creq->path, 'engine/request/uri/change_base', 'URI contains correct path' ); +} + +# test that base + path is correct +{ + ok( my $response = request('http://localhost/engine/request/uri'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); + is( $creq->base . $creq->path, $creq->uri, 'Base + Path ok' ); +} + +# test that we can use semi-colons as separators +{ + my $parameters = { + a => [ qw/1 2/ ], + b => 3, + }; + + ok( my $response = request('http://localhost/engine/request/uri?a=1;a=2;b=3'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); + is( $creq->{uri}->query, 'a=1;a=2;b=3', 'Query string ok' ); + is_deeply( $creq->{parameters}, $parameters, 'Parameters ok' ); +} diff --git a/t/engine/response/cookies.t b/t/live/engine/response/cookies.t similarity index 72% rename from t/engine/response/cookies.t rename to t/live/engine/response/cookies.t index 26de1a1..410e351 100644 --- a/t/engine/response/cookies.t +++ b/t/live/engine/response/cookies.t @@ -11,17 +11,18 @@ use Catalyst::Test 'TestApp'; 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 = {}; @@ -33,10 +34,12 @@ my $expected = { } { - 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 = {}; diff --git a/t/engine/response/errors.t b/t/live/engine/response/errors.t similarity index 100% rename from t/engine/response/errors.t rename to t/live/engine/response/errors.t diff --git a/t/live/engine/response/headers.t b/t/live/engine/response/headers.t new file mode 100644 index 0000000..fa22e73 --- /dev/null +++ b/t/live/engine/response/headers.t @@ -0,0 +1,58 @@ +#!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' ); + } + } +} diff --git a/t/live/engine/response/large.t b/t/live/engine/response/large.t new file mode 100644 index 0000000..17a7cbe --- /dev/null +++ b/t/live/engine/response/large.t @@ -0,0 +1,27 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../../lib"; + +use Test::More tests => 6; +use Catalyst::Test 'TestApp'; + +# phaylon noticed that refactored was truncating output on large images. +# This test tests 100K and 1M output content. + +my $expected = { + one => 'x' x (100 * 1024), + two => 'y' x (1024 * 1024), +}; + +for my $action ( keys %{$expected} ) { + ok( my $response = request('http://localhost/engine/response/large/' . $action ), + 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + + is( length( $response->content ), length( $expected->{$action} ), 'Length OK' ); +} + diff --git a/t/engine/response/redirect.t b/t/live/engine/response/redirect.t similarity index 100% rename from t/engine/response/redirect.t rename to t/live/engine/response/redirect.t diff --git a/t/engine/response/status.t b/t/live/engine/response/status.t similarity index 100% rename from t/engine/response/status.t rename to t/live/engine/response/status.t diff --git a/t/live/engine/setup/basics.t b/t/live/engine/setup/basics.t new file mode 100644 index 0000000..0bf2c9c --- /dev/null +++ b/t/live/engine/setup/basics.t @@ -0,0 +1,19 @@ +#!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' ); +} diff --git a/t/live/engine/setup/plugins.t b/t/live/engine/setup/plugins.t new file mode 100644 index 0000000..acf3092 --- /dev/null +++ b/t/live/engine/setup/plugins.t @@ -0,0 +1,16 @@ +#!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' ); +} diff --git a/t/lib/Catalyst/Plugin/Test/Errors.pm b/t/live/lib/Catalyst/Plugin/Test/Errors.pm similarity index 100% rename from t/lib/Catalyst/Plugin/Test/Errors.pm rename to t/live/lib/Catalyst/Plugin/Test/Errors.pm diff --git a/t/lib/Catalyst/Plugin/Test/Headers.pm b/t/live/lib/Catalyst/Plugin/Test/Headers.pm similarity index 100% rename from t/lib/Catalyst/Plugin/Test/Headers.pm rename to t/live/lib/Catalyst/Plugin/Test/Headers.pm diff --git a/t/live/lib/Catalyst/Plugin/Test/Plugin.pm b/t/live/lib/Catalyst/Plugin/Test/Plugin.pm new file mode 100644 index 0000000..0fdf99d --- /dev/null +++ b/t/live/lib/Catalyst/Plugin/Test/Plugin.pm @@ -0,0 +1,25 @@ +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; diff --git a/t/lib/TestApp.pm b/t/live/lib/TestApp.pm similarity index 60% rename from t/lib/TestApp.pm rename to t/live/lib/TestApp.pm index c4f1649..8227622 100644 --- a/t/lib/TestApp.pm +++ b/t/live/lib/TestApp.pm @@ -1,20 +1,15 @@ 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'); @@ -23,7 +18,7 @@ sub global_action : Private { sub execute { my $c = shift; my $class = ref( $c->component( $_[0] ) ) || $_[0]; - my $action = $c->actions->{reverse}->{"$_[1]"} || "$_[1]"; + my $action = "$_[1]"; my $method; @@ -36,9 +31,14 @@ sub execute { 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(@_); } diff --git a/t/lib/TestApp/Controller/Action.pm b/t/live/lib/TestApp/Controller/Action.pm similarity index 85% rename from t/lib/TestApp/Controller/Action.pm rename to t/live/lib/TestApp/Controller/Action.pm index b745e82..acd8385 100644 --- a/t/lib/TestApp/Controller/Action.pm +++ b/t/live/lib/TestApp/Controller/Action.pm @@ -5,7 +5,7 @@ use base 'Catalyst::Base'; 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'); } diff --git a/t/lib/TestApp/Controller/Action/Begin.pm b/t/live/lib/TestApp/Controller/Action/Begin.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Begin.pm rename to t/live/lib/TestApp/Controller/Action/Begin.pm diff --git a/t/lib/TestApp/Controller/Action/Default.pm b/t/live/lib/TestApp/Controller/Action/Default.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Default.pm rename to t/live/lib/TestApp/Controller/Action/Default.pm diff --git a/t/live/lib/TestApp/Controller/Action/Detach.pm b/t/live/lib/TestApp/Controller/Action/Detach.pm new file mode 100644 index 0000000..28b0f8f --- /dev/null +++ b/t/live/lib/TestApp/Controller/Action/Detach.pm @@ -0,0 +1,45 @@ +package TestApp::Controller::Action::Detach; + +use strict; +use base 'TestApp::Controller::Action'; + +sub one : Local { + my ( $self, $c ) = @_; + $c->detach('two'); + $c->forward('error'); +} + +sub two : Private { + my ( $self, $c ) = @_; + $c->forward('TestApp::View::Dump::Request'); +} + +sub error : Local { + my ( $self, $c ) = @_; + $c->res->output('error'); +} + +sub path : Local { + my ( $self, $c ) = @_; + $c->detach('/action/detach/two'); + $c->forward('error'); +} + +sub with_args : Local { + my ( $self, $c, $orig ) = @_; + $c->detach( 'args', [qq/new/] ); +} + +sub with_method_and_args : Local { + my ( $self, $c, $orig ) = @_; + $c->detach( qw/TestApp::Controller::Action::Detach args/, [qq/new/] ); +} + +sub args : Local { + my ( $self, $c, $val ) = @_; + die "Expected argument 'new', got '$val'" unless $val eq 'new'; + die "passed argument does not match args" unless $val eq $c->req->args->[0]; + $c->res->body( $c->req->args->[0] ); +} + +1; diff --git a/t/lib/TestApp/Controller/Action/End.pm b/t/live/lib/TestApp/Controller/Action/End.pm similarity index 91% rename from t/lib/TestApp/Controller/Action/End.pm rename to t/live/lib/TestApp/Controller/Action/End.pm index a132c22..f18f871 100644 --- a/t/lib/TestApp/Controller/Action/End.pm +++ b/t/live/lib/TestApp/Controller/Action/End.pm @@ -3,7 +3,7 @@ package TestApp::Controller::Action::End; use strict; use base 'TestApp::Controller::Action'; -sub end : Private { +sub end : Private { my ( $self, $c ) = @_; } diff --git a/t/lib/TestApp/Controller/Action/Forward.pm b/t/live/lib/TestApp/Controller/Action/Forward.pm similarity index 88% rename from t/lib/TestApp/Controller/Action/Forward.pm rename to t/live/lib/TestApp/Controller/Action/Forward.pm index 6a74ddd..b03eff9 100644 --- a/t/lib/TestApp/Controller/Action/Forward.pm +++ b/t/live/lib/TestApp/Controller/Action/Forward.pm @@ -28,19 +28,12 @@ sub five : Local { $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'); @@ -49,12 +42,12 @@ sub inheritance : Local { 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] ); } diff --git a/t/lib/TestApp/Controller/Action/Global.pm b/t/live/lib/TestApp/Controller/Action/Global.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Global.pm rename to t/live/lib/TestApp/Controller/Action/Global.pm diff --git a/t/lib/TestApp/Controller/Action/Inheritance.pm b/t/live/lib/TestApp/Controller/Action/Inheritance.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Inheritance.pm rename to t/live/lib/TestApp/Controller/Action/Inheritance.pm diff --git a/t/lib/TestApp/Controller/Action/Local.pm b/t/live/lib/TestApp/Controller/Action/Local.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Local.pm rename to t/live/lib/TestApp/Controller/Action/Local.pm diff --git a/t/lib/TestApp/Controller/Action/Path.pm b/t/live/lib/TestApp/Controller/Action/Path.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Path.pm rename to t/live/lib/TestApp/Controller/Action/Path.pm diff --git a/t/lib/TestApp/Controller/Action/Private.pm b/t/live/lib/TestApp/Controller/Action/Private.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Private.pm rename to t/live/lib/TestApp/Controller/Action/Private.pm diff --git a/t/lib/TestApp/Controller/Action/Regexp.pm b/t/live/lib/TestApp/Controller/Action/Regexp.pm similarity index 100% rename from t/lib/TestApp/Controller/Action/Regexp.pm rename to t/live/lib/TestApp/Controller/Action/Regexp.pm diff --git a/t/live/lib/TestApp/Controller/Action/Streaming.pm b/t/live/lib/TestApp/Controller/Action/Streaming.pm new file mode 100644 index 0000000..9ad394c --- /dev/null +++ b/t/live/lib/TestApp/Controller/Action/Streaming.pm @@ -0,0 +1,17 @@ +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; diff --git a/t/lib/TestApp/Controller/Dump.pm b/t/live/lib/TestApp/Controller/Dump.pm similarity index 100% rename from t/lib/TestApp/Controller/Dump.pm rename to t/live/lib/TestApp/Controller/Dump.pm diff --git a/t/live/lib/TestApp/Controller/Engine/Request/URI.pm b/t/live/lib/TestApp/Controller/Engine/Request/URI.pm new file mode 100644 index 0000000..cb86f30 --- /dev/null +++ b/t/live/lib/TestApp/Controller/Engine/Request/URI.pm @@ -0,0 +1,31 @@ +package TestApp::Controller::Engine::Request::URI; + +use strict; +use base 'Catalyst::Base'; + +sub default : Private { + my ( $self, $c ) = @_; + + $c->forward('TestApp::View::Dump::Request'); +} + +sub change_path : Local { + my ( $self, $c ) = @_; + + # change the path + $c->req->path( '/my/app/lives/here' ); + + $c->forward('TestApp::View::Dump::Request'); +} + +sub change_base : Local { + my ( $self, $c ) = @_; + + # change the base and uri paths + $c->req->base->path( '/new/location' ); + $c->req->uri->path( '/new/location/engine/request/uri/change_base' ); + + $c->forward('TestApp::View::Dump::Request'); +} + +1; diff --git a/t/lib/TestApp/Controller/Engine/Request/Uploads.pm b/t/live/lib/TestApp/Controller/Engine/Request/Uploads.pm similarity index 100% rename from t/lib/TestApp/Controller/Engine/Request/Uploads.pm rename to t/live/lib/TestApp/Controller/Engine/Request/Uploads.pm diff --git a/t/lib/TestApp/Controller/Engine/Response/Cookies.pm b/t/live/lib/TestApp/Controller/Engine/Response/Cookies.pm similarity index 100% rename from t/lib/TestApp/Controller/Engine/Response/Cookies.pm rename to t/live/lib/TestApp/Controller/Engine/Response/Cookies.pm diff --git a/t/lib/TestApp/Controller/Engine/Response/Errors.pm b/t/live/lib/TestApp/Controller/Engine/Response/Errors.pm similarity index 100% rename from t/lib/TestApp/Controller/Engine/Response/Errors.pm rename to t/live/lib/TestApp/Controller/Engine/Response/Errors.pm diff --git a/t/lib/TestApp/Controller/Engine/Response/Headers.pm b/t/live/lib/TestApp/Controller/Engine/Response/Headers.pm similarity index 52% rename from t/lib/TestApp/Controller/Engine/Response/Headers.pm rename to t/live/lib/TestApp/Controller/Engine/Response/Headers.pm index 7b624f4..a93fe31 100644 --- a/t/lib/TestApp/Controller/Engine/Response/Headers.pm +++ b/t/live/lib/TestApp/Controller/Engine/Response/Headers.pm @@ -5,9 +5,9 @@ use base 'Catalyst::Base'; 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'); } diff --git a/t/live/lib/TestApp/Controller/Engine/Response/Large.pm b/t/live/lib/TestApp/Controller/Engine/Response/Large.pm new file mode 100644 index 0000000..e9e488c --- /dev/null +++ b/t/live/lib/TestApp/Controller/Engine/Response/Large.pm @@ -0,0 +1,16 @@ +package TestApp::Controller::Engine::Response::Large; + +use strict; +use base 'Catalyst::Base'; + +sub one : Relative { + my ( $self, $c ) = @_; + $c->res->output( 'x' x (100 * 1024) ); +} + +sub two : Relative { + my ( $self, $c ) = @_; + $c->res->output( 'y' x (1024 * 1024) ); +} + +1; diff --git a/t/lib/TestApp/Controller/Engine/Response/Redirect.pm b/t/live/lib/TestApp/Controller/Engine/Response/Redirect.pm similarity index 100% rename from t/lib/TestApp/Controller/Engine/Response/Redirect.pm rename to t/live/lib/TestApp/Controller/Engine/Response/Redirect.pm diff --git a/t/lib/TestApp/Controller/Engine/Response/Status.pm b/t/live/lib/TestApp/Controller/Engine/Response/Status.pm similarity index 100% rename from t/lib/TestApp/Controller/Engine/Response/Status.pm rename to t/live/lib/TestApp/Controller/Engine/Response/Status.pm diff --git a/t/live/lib/TestApp/View/Dump.pm b/t/live/lib/TestApp/View/Dump.pm new file mode 100644 index 0000000..71130aa --- /dev/null +++ b/t/live/lib/TestApp/View/Dump.pm @@ -0,0 +1,55 @@ +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; diff --git a/t/lib/TestApp/View/Dump/Parameters.pm b/t/live/lib/TestApp/View/Dump/Parameters.pm similarity index 82% rename from t/lib/TestApp/View/Dump/Parameters.pm rename to t/live/lib/TestApp/View/Dump/Parameters.pm index d774a33..30d53df 100644 --- a/t/lib/TestApp/View/Dump/Parameters.pm +++ b/t/live/lib/TestApp/View/Dump/Parameters.pm @@ -1,7 +1,7 @@ package TestApp::View::Dump::Parameters; use strict; -use base qw[TestApp::View::Dump]; +use base 'TestApp::View::Dump'; sub process { my ( $self, $c ) = @_; diff --git a/t/lib/TestApp/View/Dump/Request.pm b/t/live/lib/TestApp/View/Dump/Request.pm similarity index 100% rename from t/lib/TestApp/View/Dump/Request.pm rename to t/live/lib/TestApp/View/Dump/Request.pm diff --git a/t/lib/TestApp/View/Dump/Response.pm b/t/live/lib/TestApp/View/Dump/Response.pm similarity index 100% rename from t/lib/TestApp/View/Dump/Response.pm rename to t/live/lib/TestApp/View/Dump/Response.pm diff --git a/t/live/plugin/loaded.t b/t/live/plugin/loaded.t new file mode 100644 index 0000000..59c8823 --- /dev/null +++ b/t/live/plugin/loaded.t @@ -0,0 +1,25 @@ +#!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' ); diff --git a/t/plugin/loaded.t b/t/plugin/loaded.t deleted file mode 100644 index 2c3a07d..0000000 --- a/t/plugin/loaded.t +++ /dev/null @@ -1,26 +0,0 @@ -#!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' ); -} diff --git a/t/unit/core/component.t b/t/unit/core/component.t new file mode 100644 index 0000000..d12ad59 --- /dev/null +++ b/t/unit/core/component.t @@ -0,0 +1,28 @@ +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? diff --git a/t/unit/core/threads.t b/t/unit/core/threads.t new file mode 100644 index 0000000..43e55b0 --- /dev/null +++ b/t/unit/core/threads.t @@ -0,0 +1,49 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../../live/lib"; + +use Test::More; +use Catalyst::Test 'TestApp'; +use Catalyst::Request; +use Config; + +if ( $Config{useithreads} && !$ENV{CATALYST_SERVER} ) { + require threads; + plan tests => 3; +} +else { + if ( $ENV{CATALYST_SERVER} ) { + plan skip_all => 'Using remote server'; + } + else { + plan skip_all => 'Needs a Perl with ithreads enabled'; + } +} + +no warnings 'redefine'; +sub request { + my $thr = threads->new( + sub { TestApp->run(@_) }, + @_ + ); + $thr->join; +} + +# test that running inside a thread works ok +{ + my @expected = qw[ + TestApp::Controller::Action::Default->begin + TestApp::Controller::Action::Default->default + TestApp::View::Dump::Request->process + ]; + + my $expected = join( ", ", @expected ); + + ok( my $response = request('http://localhost/action/default'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' ); +} diff --git a/t/unit/core/uri_for.t b/t/unit/core/uri_for.t new file mode 100644 index 0000000..f9d5e09 --- /dev/null +++ b/t/unit/core/uri_for.t @@ -0,0 +1,30 @@ +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' );