CGI-Application-Dispatch-3.12000755001750001750 012024502644 15105 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/META.json000444001750001750 327512024502644 16672 0ustar00markmark000000000000{ "abstract" : "Dispatch requests to CGI::Application based objects", "author" : [ "Michael Peters " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4003, CPAN::Meta::Converter version 2.112150", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CGI-Application-Dispatch", "prereqs" : { "build" : { "requires" : { "CGI::PSGI" : 0, "Plack" : "0.9956", "Test::LongString" : 0, "Test::More" : 0 } }, "configure" : { "requires" : { "Module::Build" : "0.38" } }, "runtime" : { "requires" : { "CGI::Application" : "4.50", "Exception::Class" : "1.2", "HTTP::Exception" : 0, "Try::Tiny" : 0, "perl" : "v5.6.0", "version" : "0.82" } } }, "provides" : { "CGI::Application::Dispatch" : { "file" : "lib/CGI/Application/Dispatch.pm", "version" : "3.12" }, "CGI::Application::Dispatch::PSGI" : { "file" : "lib/CGI/Application/Dispatch/PSGI.pm", "version" : "3.12" }, "CGI::Application::Dispatch::Regexp" : { "file" : "lib/CGI/Application/Dispatch/Regexp.pm", "version" : "3.04" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/markstos/CGI--Application--Dispatch" } }, "version" : "3.12" } CGI-Application-Dispatch-3.12/MANIFEST000444001750001750 72612024502644 16360 0ustar00markmark000000000000Build.PL Changes lib/CGI/Application/Dispatch.pm lib/CGI/Application/Dispatch/PSGI.pm lib/CGI/Application/Dispatch/Regexp.pm MANIFEST META.json META.yml t/cgi.t t/conf/extra.conf.in t/conf/modperl_extra.pl t/handler.t t/lib/Module/Name.pm t/lib/MyApp/Dispatch.pm t/lib/MyApp/DispatchPSGI.pm t/lib/MyApp/DispatchRest.pm t/lib/MyApp/DispatchTable.pm t/lib/MyApp/DispatchTablePSGI.pm t/lib/MyApp/Module/Bad.pm t/lib/MyApp/Module/Name.pm t/lib/MyApp/Module/Rest.pm t/psgi.t CGI-Application-Dispatch-3.12/META.yml000444001750001750 203412024502644 16512 0ustar00markmark000000000000--- abstract: 'Dispatch requests to CGI::Application based objects' author: - 'Michael Peters ' build_requires: CGI::PSGI: 0 Plack: 0.9956 Test::LongString: 0 Test::More: 0 configure_requires: Module::Build: 0.38 dynamic_config: 1 generated_by: 'Module::Build version 0.4003, CPAN::Meta::Converter version 2.112150' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: CGI-Application-Dispatch provides: CGI::Application::Dispatch: file: lib/CGI/Application/Dispatch.pm version: 3.12 CGI::Application::Dispatch::PSGI: file: lib/CGI/Application/Dispatch/PSGI.pm version: 3.12 CGI::Application::Dispatch::Regexp: file: lib/CGI/Application/Dispatch/Regexp.pm version: 3.04 requires: CGI::Application: 4.50 Exception::Class: 1.2 HTTP::Exception: 0 Try::Tiny: 0 perl: v5.6.0 version: 0.82 resources: license: http://dev.perl.org/licenses/ repository: https://github.com/markstos/CGI--Application--Dispatch version: 3.12 CGI-Application-Dispatch-3.12/Build.PL000444001750001750 256212024502644 16543 0ustar00markmark000000000000my $have_apache_test = 0; my $build_pkg = 'Module::Build'; eval "require Apache::Test"; unless( $@ ) { $build_pkg = 'Apache::TestMB'; $have_apache_test = 1; } eval "require $build_pkg"; my $build = $build_pkg->new( module_name => 'CGI::Application::Dispatch', license => 'perl', configure_requires => { 'Module::Build' => 0.38 }, requires => { 'perl' => '5.6.0', # a new 'version' is only required to solve rare install problem. # https://rt.cpan.org/Ticket/Display.html?id=56283 'version' => 0.82, 'CGI::Application' => '4.50', # For native PSGI support. 'HTTP::Exception' => 0, 'Exception::Class' => 1.2, 'Try::Tiny' => 0, }, build_requires => { 'CGI::PSGI' => 0, # recommended by CGI::Application, but not required. We still need it at least to test with. 'Test::More' => 0, 'Test::LongString' => 0, 'Plack' => 0.9956, # really, we just depend on Plack::Test, but Plack::Test has not declared a version. $have_apache_test ? ( 'Apache::Test' => 0 ) : (), }, meta_merge => { resources => { repository => 'https://github.com/markstos/CGI--Application--Dispatch', }, }, ); $build->create_build_script; CGI-Application-Dispatch-3.12/Changes000444001750001750 2351512024502644 16563 0ustar00markmark000000000000Revision history for Perl extension CGI::Application::Dispatch. 3.12 September 10th, 2012 [BUG FIXES] - Further fix diagnostic message in some cases when exceptions are thrown. (Michael Lackhoff) 3.11 September 10th, 2012 (No code changes) [INTERNALS] - Fixed test for rethrowing HTTP::Exception objects (Graham TerMarsch) 3.10 September 2nd, 2012 [NEW FEATURES] - CGI::Application::Dispatch::PSGI now allows exceptions thrown as HTTP::Exception objects to bubble up in some cases. See the new documentation section on "Exception Handling" for details. (Mark Stosberg, Graham TerMarsch, RT#79022) [BUG FIXES] - When auto_rest was enabled and no run mode was found, a 404 could have been returned instead of defaulting to start mode. We now correctly default to the start_mode(). (James Q.L., Ron Savage, Mark Stosberg) [DOCUMENTATION] - Docs have been expanded to explain how /foo/:rm? resolves, and interaction with start_mode() when no run mode is found. (Mark Stosberg) [INTERNALS] - Fix diagnostic message in some cases when exceptions are thrown (Michael Lackhoff) - Added test coverage for auto_rest to CGI::Application::Dispatch::PSGI (Mark Stosberg) - POD formatting fix in Dispatch.pm - Fix Perl 5.14 compatibility warning (chorny, RENEEB@cpan.org, SILASMONK@cpan.org) 3.07 September 9th, 2011 Fix t/cgi.t test failures caused by Try::Tiny refactor in 3.05 (Yoshihiro Sasaki) 3.06 September 9th, 2011 Typo fix in "use" statement, introduced in 3.05 (Nicholas Bamber) 3.05 September 5th, 2011 Removed Exception::Class::TryCatch with the already required Try::Tiny thereby eliminating one dependency. (Timothy Appnel) 3.04 June 29th, 2011 No code changes. [DOCUMENTATION] - spelling fixes (Nicholas Bamber) 3.03 June 25th, 2011 No code changes. [INTERNALS] - further dependency refinement and a typo fix. (Nicholas Bamber) 3.02 June 24th, 2011 No code changes. [INTERNALS] - further refined dependency definitions. (Nicholas Bamber) 3.01 Jun 23, 2011 No code changes. [INTERNALS] - Fixed Build.PL issue that was causing tests to fail in a lot of environments. (Brad Oaks) - cleaned up MANIFEST 3.00 Jun 16, 2011 [FEATURES] - PSGI support is improved. CGI::Application::Dispatch is now been rewritten and is included in this distribution. It is no longer a wrapper around the older dispatcher, but is completely PSGI-native. Performance should be improved a bit as well. [THINGS THAT MIGHT BREAK YOUR CODE] As part of the significant update to PSGI support, you'll need to update a couple lines of code in your "dispatch.cgi" script if you were using an older version of CGI::Application::Dispatch::PSGI. See the section on "Backwards Compatibility" in that documentation. [INTERNALS] - CGI::Application 4.5 is now required for the newer native PSGI support. - Exceptions in CGI::Application::Dispatch::PSGI are now handled with HTTP::Exception. This in turn depends on HTTP::Status, which is currently in a distribution which depends on HTML::Parser, which depends having a C-compiler available. I don't consider this ideal, as I'd like to be able to support the easy installation of a pure-Perl CGI::Application stack. This could possibly be addressed in the future by removing the false dependency on a C-compiler from HTTP::Status, or we could return to use Exception::Class directly for exception handling. The except format of the default thrown exceptions may change in the future. 2.18 Sep 9, 2010 - Update Build.PL to require a newer version of "version", to address a rare installation problem. (RT#56283) Thanks to Jim Brandt and others. 2.17 Dec 30, 2009 - Update examples to use FindBin::Real instead of FindBin, since FindBin is not fully mod_perl compatible. (Mark Stosberg) - Fix typo in POD (Alexander Becker) 2.16 Mar 23, 2009 - Fix: "$app->run() error handler breaks exception objects." RT#43340 (dekimsey) - Documentation improvements (Dave Baker, thinc) - remove "Makefile.PL", which appears to related to some test failures. Build.PL seems to work reliably. If removing Makefile.PL is a problem for you, maybe you have a better solution to RT#39793: https://rt.cpan.org/Ticket/Display.html?id=39793 (Mark Stosberg) 2.15 Dec 4, 2008 - Logging improvement: Quit duplicating $ENV{REQUEST_URI} for Not Found requests (Mark Stosberg) - Logging improvement: Remove stray "'" character (Mark Stosberg) 2.14 Nov 2, 2008 - New feature: $ENV{PATH_INFO} is now abstracted through dispatch_path(). (RT#34069, Bradley Bailey) - Attempted fix for "Couldn't open t/TEST.PL" error, RT#39793. Add comments to that ticket if you still have "make test" problems with Apache::Test. (Puneet Kishor, Kevin, Mark Stosberg) http://rt.cpan.org/Public/Bug/Display.html?id=39793 2.13 Sep 16, 2008 - Fixing various install issues by having a dumber Makefile.PL and Build.PL (#37859, Thanks to lkundrak) 2.12 Jan 03, 2007 - Creating our own Makefile.PL instead of relying on create_makefile_pl - Fixed test problems with GET() not being exported by implicitly by some versions of Apache::Test - Fixed RT #32037 and clarifying some documentation 2.11 Oct 11, 2007 - Fixed RT #30135 by using "slash" and "backslash" properly [Ricardo Signes and Michael Peters] - Fixed RT #30134 [Ricardo Signes and Michael Peters] - Fixed RT #28979 [GTERMARS] - Fixed RT #25298 [cpan@punch.net and Michael Peters] - Fixed RT #25297 [cpan@punch.net and Michael Peters] - Fixing cpan install problem with autogenerated Makefile.PL - Fixing failing test when IO::Scalar is not installed 2.10 Jan 15, 2007 - Added REST support with 'auto_rest', 'auto_rest_lc' and '[METHOD]' support in dispatch rules [Michael Peters] - Added wildcard matching token to dispatch rules [Shawn Sorichetti] - Removed url caching [Michael Peters, Timothy Appnel] - Documentation fixes in examples [dsteinbrunner, ZACKSE and Stew Heckenberg] 2.03 Sep 29, 2006 - When running a cached URL, we were mistakenly using the '$r' object from the cached request instead of the newly given one under mod_perl. 2.02 Aug 16, 2006 - args_to_new were not merging PARAMS properly [Michael Peters] 2.01 - Improved docs for CGI::Application::Dispatch::Regexp, including a typo fix in the Synopsis. [Mark Stosberg] - Fixed bug in mod_perl 2 where status/error codes were sent to the browser after the content [Michael Peters] 2.00 Jul 3rd, 2006 - Some errors in run() execution were being silently ignored [Michael Peters] - POD correction [Ron Savage] - When the PATH_INFO can't be parsed, a proper 404 is returned instead of an internal server error. [Mark Stosberg] - Fix error page printing. [Mark Stosberg] - Added experimental CGI::Application::Dispatch::Regexp to distribution 2.00_05 - Fully working on mod_perl 2 - Using Exception::Class internally to handle exceptions instead of passing around return codes - Added 'not_found' option to dispatch() - Added more flexible error handling [Viacheslav Sheveliov] - Improve mod_rewrite examples [Mark Stosberg] - removed now unused variables [Viacheslav Sheveliov] - speed up some of the rule-to-regex processing [Viacheslav Sheveliov] 2.00_04 - handler() now sends a 404 if the run mode can't be found either - some environments don't set the PATH_INFO if it's blank, so handle that better - added _get_cache() and _set_cache() protected methods to further help subclassing [Viacheslav Sheveliov, Michael Peters] - now passing same args passed from dispatch() into dispatch_args() [Viacheslav Sheveliov, Michael Peters) ] - Added built-in 404 page if no application is found to dispatch to. [Mark Stosberg] 2.00_03 - Added cache of REQUEST_URI -> dispatch mapping [Mark Stosberg, Michael Peters] - fixed local args_to_new overrides [Mark Stosberg] - added support for debug flag to dispatch() [Mark Stosberg] 2.00_02 - Added optional-variable tokens to dispatch tables - added more docs and examples for dispatch tables 2.00_01 - Initial rewrite of new API and new dispatch table 1.04 (Jun. 27, 2005) - Small changes to correspond to official mod_perl 2.0 release and API change (see http://perl.apache.org/docs/2.0/rename.html) 1.03 (Mar. 4, 2005) - 100% test coverage 1.02 (Jan. 20, 2005) - Added mod_perl 2 support - Added TABLE dispatch option - fixed bug with a PATH_INFO value of '/' - fixed bug where DEFAULT doesn't have an initial '/' - fixed testing issues when Apache::TestMB is not installed [Cees Hek] - fixed security whole with reqard to untainting module names [Cees Hek] - minor documentation improvements 1.01 (Jan. 8, 2005) - moved dependancy on perl 5.8.x to 5.6.x since method attributes were include - added Apache::Test as a build dependancy 1.0 (Jan. 6, 2005) - fixed bug which prevented overriding of certain methods - upped required perl version to 5.8.0 because of method attributes 0.04 - added CGIAPP_DISPATCH_DEFAULT option to specify default PATH_INFO value - added CGIAPP_DISPATCH_PATH which gets passed to new()'s PARAMS for use by the application module - any parameters passed into dispatch() are then passed into the application's new() - added Apache::Test tests to the test suite 0.03 (Oct. 29, 2004) - missing files from MANIFEST - minor optimizations 0.02 (Oct. 19, 2004) - find and fix document mistakes - add aliases to options (PREFIX and RM) for dispatch() - improved test - mention security concern with not using PREFIX 0.01 (Sep. 12, 2004) - First version CGI-Application-Dispatch-3.12/t000755001750001750 012024502644 15350 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/t/cgi.t000444001750001750 1454712024502644 16467 0ustar00markmark000000000000use Test::More; use Test::LongString max => 500; use strict; use warnings; use lib 't/lib'; my $COUNT; plan(tests => $COUNT); BEGIN { $COUNT += 5 } # make sure we can get to our modules require_ok('CGI::Application::Dispatch'); require_ok('Module::Name'); require_ok('MyApp::Module::Name'); require_ok('MyApp::Dispatch'); require_ok('MyApp::DispatchTable'); local $ENV{CGI_APP_RETURN_ONLY} = '1'; my $output = ''; # to capture and junk STDERR my $junk; { no strict; open SAVE_ERR, ">&STDERR"; close STDERR; open STDERR, ">", \$junk or warn "Could not redirect STDERR?\n"; } BEGIN { $COUNT += 1 } # make sure that dispatch_path() is returning PATH_INFO { local $ENV{PATH_INFO} = '/test/dispatch_path/'; is(CGI::Application::Dispatch->dispatch_path, '/test/dispatch_path/', '->dispatch_path() is returning PATH_INFO'); } BEGIN { $COUNT += 2 } # module name { # with starting '/' local $ENV{PATH_INFO} = '/module_name/rm1'; my $output = CGI::Application::Dispatch->dispatch(); contains_string($output, 'Module::Name->rm1', 'dispatch(): module_name'); # without starting '/' local $ENV{PATH_INFO} = 'module_name/rm1'; $output = ''; $output = CGI::Application::Dispatch->dispatch(); contains_string($output, 'Module::Name->rm1', 'dispatch(): module_name'); } BEGIN { $COUNT += 1 } # prefix { local $ENV{PATH_INFO} = '/module_name/rm2'; $output = CGI::Application::Dispatch->dispatch(prefix => 'MyApp',); contains_string($output, 'MyApp::Module::Name->rm2', 'dispatch(): prefix'); } BEGIN { $COUNT += 1 } # grabs the RM from the PATH_INFO { # with run mode local $ENV{PATH_INFO} = '/module_name/rm2'; $output = CGI::Application::Dispatch->dispatch(prefix => 'MyApp',); contains_string($output, 'MyApp::Module::Name->rm2', 'RM correct'); } BEGIN { $COUNT += 1 } # extra things passed to dispatch() get passed into new() { local $ENV{PATH_INFO} = '/module_name/rm3'; $output = CGI::Application::Dispatch->dispatch( prefix => 'MyApp', PARAMS => {my_param => 'testing',}, ); contains_string($output, 'MyApp::Module::Name->rm3 my_param=testing', 'PARAMS passed through'); } BEGIN { $COUNT += 2 } # use default { # using short cuts names local $ENV{PATH_INFO} = ''; $output = CGI::Application::Dispatch->dispatch( prefix => 'MyApp', default => '/module_name/rm2', ); contains_string($output, 'MyApp::Module::Name->rm2', 'default'); # with trailing '/' local $ENV{PATH_INFO} = '/'; $output = CGI::Application::Dispatch->dispatch( prefix => 'MyApp', default => '/module_name/rm2', ); contains_string($output, 'MyApp::Module::Name->rm2', 'default'); } BEGIN { $COUNT += 1 } # override translate_module_name() { local $ENV{PATH_INFO} = '/something_strange'; $output = MyApp::Dispatch->dispatch(); contains_string($output, 'MyApp::Module::Name->rm1', 'override translate_module_name()'); } BEGIN { $COUNT += 2 } # cause errors { # non-existant module local $ENV{PATH_INFO} = '/foo'; $output = CGI::Application::Dispatch->dispatch(); like($output, qr/Not Found/i); # not a valid path_info local $ENV{PATH_INFO} = '//'; $output = CGI::Application::Dispatch->dispatch(); like($output, qr/Internal Server Error/i); } BEGIN { $COUNT += 1 } # args_to_new { local $ENV{PATH_INFO} = '/module_name/rm4'; $output = CGI::Application::Dispatch->dispatch( prefix => 'MyApp', args_to_new => {PARAMS => {my_param => 'more testing'},}, ); contains_string( $output, 'MyApp::Module::Name->rm3 my_param=more testing', 'PARAMS passed through' ); } BEGIN { $COUNT += 9 } # use a full dispatch table in a subclass { local $ENV{PATH_INFO} = '/module_name'; $output = MyApp::DispatchTable->dispatch(); contains_string($output, 'MyApp::Module::Name->rm1', 'matched :app'); local $ENV{PATH_INFO} = '/module_name/rm2'; $output = MyApp::DispatchTable->dispatch(); contains_string($output, 'MyApp::Module::Name->rm2', 'matched :app/:rm'); local $ENV{PATH_INFO} = '/module_name/rm3/stuff'; $output = MyApp::DispatchTable->dispatch(); contains_string( $output, 'MyApp::Module::Name->rm3 my_param=stuff', 'matched :app/:rm/:my_param' ); local $ENV{PATH_INFO} = '/module_name/bar/stuff'; $output = MyApp::DispatchTable->dispatch(); contains_string( $output, 'MyApp::Module::Name->rm3 my_param=stuff', 'matched :app/bar/:my_param' ); local $ENV{PATH_INFO} = '/foo/bar'; $output = MyApp::DispatchTable->dispatch(); contains_string($output, 'MyApp::Module::Name->rm2', 'matched foo/bar'); local $ENV{PATH_INFO} = '/module_name/foo'; $output = MyApp::DispatchTable->dispatch(); contains_string($output, 'MyApp::Module::Name->rm3 my_param=', 'missing optional'); local $ENV{PATH_INFO} = '/module_name/foo/weird'; $output = MyApp::DispatchTable->dispatch(); contains_string($output, 'MyApp::Module::Name->rm3 my_param=weird', 'present optional'); local $ENV{PATH_INFO} = '/module_name/baz/this/is/extra'; $output = MyApp::DispatchTable->dispatch(); contains_string( $output, 'MyApp::Module::Name->rm5 dispatch_url_remainder=this/is/extra', 'url remainder' ); local $ENV{PATH_INFO} = '/module_name/bap/this/is/extra'; $output = MyApp::DispatchTable->dispatch(); contains_string( $output, 'MyApp::Module::Name->rm5 the_rest=this/is/extra', 'named url remainder' ); } BEGIN { $COUNT += 1 } # local args_to_new { local $ENV{PATH_INFO} = '/module_name/local_args_to_new'; $output = CGI::Application::Dispatch->dispatch( prefix => 'MyApp', table => [':app/:rm' => {args_to_new => {TMPL_PATH => 'events',},},], ); contains_string($output, 'events', 'local args_to_new works'); } BEGIN { $COUNT += 1 } # 404 { local $ENV{PATH_INFO} = '/somewhere_else'; $output = CGI::Application::Dispatch->dispatch( prefix => 'MyApp', table => [':app/:rm' => {args_to_new => {TMPL_PATH => 'events',},},], ); like_string( $output, qr/404 not found/i, "proper 404 error is returned when PATH_INFO isn't parsed." ); } # restore STDERR { close STDERR; open STDERR, ">&SAVE_ERR"; close SAVE_ERR; } CGI-Application-Dispatch-3.12/t/psgi.t000444001750001750 1777412024502644 16674 0ustar00markmark000000000000# make sure we can get to our modules use lib 't/lib'; use Test::More 'no_plan'; use Plack::Test; use HTTP::Request::Common; use CGI::Application::Dispatch::PSGI; use Module::Name; use MyApp::Module::Name; use MyApp::DispatchPSGI; use MyApp::DispatchTablePSGI; my $output = ''; # to capture and junk STDERR my $junk; { no strict; open SAVE_ERR, ">&STDERR"; close STDERR; open STDERR, ">", \$junk or warn "Could not redirect STDERR?\n"; } # module name test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi, client => sub { my $cb = shift; my $res = $cb->(GET "/module_name/rm1"); like($res->content, qr/\QModule::Name->rm1/, 'as_psgi(): module_name'); }; # prefix test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi(prefix => 'MyApp'), client => sub { my $cb = shift; my $res = $cb->(GET '/module_name/rm2'); like($res->content, qr/\QMyApp::Module::Name->rm2/, 'as_psgi(): prefix'); }; # extra things passed to dispatch() get passed into new() # Not supported anymore. # test_psgi # app => CGI::Application::Dispatch::PSGI->as_psgi( # prefix => 'MyApp', # PARAMS => {my_param => 'testing'}, # ), # client => sub { # my $cb = shift; # my $res = $cb->(GET '/module_name/rm3'); # like($res->content, qr/\QMyApp::Module::Name->rm3 my_param=testing/, 'PARAMS passed through') # }; # use default, with shortcut name test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi( prefix => 'MyApp', default => '/module_name/rm2'), client => sub { my $cb = shift; my $res = $cb->(GET ''); like($res->content,qr/\QMyApp::Module::Name->rm2/, 'default, with shortcut name'); }; # use default, with trailing / test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi( prefix => 'MyApp', default => '/module_name/rm2'), client => sub { my $cb = shift; my $res = $cb->(GET '/'); like($res->content,qr/\QMyApp::Module::Name->rm2/, 'default, trailing /'); }; # override translate_module_name() test_psgi app => MyApp::DispatchPSGI->as_psgi, client => sub { my $cb = shift; my $res = $cb->(GET '/something_string'); like($res->content, qr/\QMyApp::Module::Name->rm1/, 'override translate_module_name()'); }; # cause errors test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi, client => sub { my $cb = shift; my $res = $cb->(GET '/foo'); is $res->code, '404', 'non-existent module throws 404'; like $cb->(GET '/foo')->content, qr/Not Found/i, 'non-existent module'; like $cb->(GET '//')->status_line, qr/404 Not Found/i, 'not a valid path_info'; }; # args_to_new test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi( prefix => 'MyApp', args_to_new => {PARAMS => {my_param => 'more testing'},}, ), client => sub { like shift->(GET '/module_name/rm4')->content, qr/\QMyApp::Module::Name->rm3 my_param=more testing/, 'PARAMS passed through'; }; # use a full dispatch table in a subclass test_psgi app => MyApp::DispatchTablePSGI->as_psgi, client => sub { my $cb = shift; like $cb->(GET '/module_name')->content, qr/\QMyApp::Module::Name->rm1/, 'matched :app'; like $cb->(GET '/module_name/rm2')->content, qr/\QMyApp::Module::Name->rm2/, 'matched :app/:rm'; like $cb->(GET '/module_name/rm3/stuff')->content, qr/\QMyApp::Module::Name->rm3 my_param=stuff/, 'matched :app/:rm/:my_param'; like $cb->(GET '/module_name/bar/stuff')->content, qr/\QMyApp::Module::Name->rm3 my_param=stuff/, 'matched :app/bar/:my_param'; like $cb->(GET '/foo/bar')->content, qr/\QMyApp::Module::Name->rm2/, 'matched foo/bar'; like $cb->(GET '/module_name/foo')->content, qr/\QMyApp::Module::Name->rm3 my_param=/, 'missing optional'; like $cb->(GET '/module_name/foo/weird')->content, qr/\QMyApp::Module::Name->rm3 my_param=weird/, 'present optional'; like $cb->(GET '/module_name/baz/this/is/extra')->content, qr{\QMyApp::Module::Name->rm5 dispatch_url_remainder=this/is/extra}, 'url remainder'; like $cb->(GET '/module_name/bap/this/is/extra')->content, qr{\QMyApp::Module::Name->rm5 the_rest=this/is/extra}, 'named url remainder'; }; # args_to_new, throwing HTTP::Exceptions test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi( prefix => 'MyApp', table => [':app/:rm' => {args_to_new => {TMPL_PATH => 'events'}}] ), client => sub { my $cb = shift; # args_to_new like $cb->(GET '/module_name/local_args_to_new')->content, qr/events/, 'args_to_new works'; # When an HTTP::Exception is thrown from error_mode, it is passed through. my $res = $cb->(GET '/module_name/throw_http_exception'); is($res->code,405,"a thrown HTTP::Exception is bubbled up"); like($res->as_string, qr/my 405 exception/, "HTTP::Exception content is passed along"); }; # 404 test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi( prefix => 'MyApp', table => [':app/:rm' => {args_to_new => {TMPL_PATH => 'events'}}] ), client => sub { my $cb = shift; like $cb->(GET '/somewhere_else')->status_line, qr/404 not found/i, }; # auto_rest test_psgi app => CGI::Application::Dispatch::PSGI->as_psgi( auto_rest => 1, prefix => 'MyApp', table => [ ':app/rm3[get]' => { rm => 'get_rm3', auto_rest => 0 }, ':app/rm4' => { auto_rest => 0, rm => 'rm4' }, ':app/rm2' => { auto_rest_lc => 1, rm => 'rm2' }, ':app/:rm?' => { }, ], ), client => sub { my $cb = shift; my $res = $cb->(GET '/module_rest/rm1'); ok($res->is_success); like($res->content, qr{MyApp::Module::Rest->rm1_GET}, 'auto_rest GET'); $res = $cb->(POST '/module_rest/rm1'); ok($res->is_success); like($res->content, qr{MyApp::Module::Rest->rm1_POST}, 'auto_rest POST'); $res = $cb->(POST '/module_rest/rm2'); ok($res->is_success); $content = $res->content; like($res->content, qr{App::Module::Rest->rm2_post}, 'auto_rest_lc POST'); $res = $cb->(GET '/module_rest/rm3'); ok($res->is_success); $content = $res->content; like($res->content, qr{App::Module::Rest->get_rm3}, 'HTTP method in rule'); $res = $cb->(GET '/module_rest/rm4'); ok($res->is_success); like($res->content, qr{App::Module::Rest->rm4}, 'non-auto_rest GET'); unlike($res->content, qr{App::Module::Rest->rm4_GET}, 'non-auto_rest GET'); $res = $cb->(POST '/module_rest/rm4'); ok($res->is_success); like($res->content, qr{App::Module::Rest->rm4}, 'non-auto_rest POST'); unlike($res->content, qr{App::Module::Rest->rm4_POST}, 'non-auto_rest POST'); $res = $cb->(GET '/module_rest'); ok($res->is_success); like($res->content, qr{MyApp::Module::Rest->rm1_GET}, 'auto_rest check of /:rm? and start_mode'); }; # restore STDERR { close STDERR; open STDERR, ">&SAVE_ERR"; close SAVE_ERR; } CGI-Application-Dispatch-3.12/t/handler.t000444001750001750 1516712024502644 17341 0ustar00markmark000000000000use strict; use warnings; use Test::More; my $COUNT; BEGIN { $COUNT = 0 }; eval { require Apache::Test }; if($@) { plan(skip_all => 'Apache::Test is not installed'); } else { require Apache::Test; require Apache::TestRequest; Apache::Test->import(qw(have_lwp need_module :withtestmore)); Apache::TestRequest->import(qw(GET POST)); plan(tests => $COUNT, need_module('Apache::TestMB'), have_lwp()); } my $response; my $content; BEGIN { $COUNT += 2 } # PATH_INFO is translated correctly { $response = GET('/app1/module_name/rm1'); ok($response->is_success); $content = $response->content; contains_string($content, 'Module::Name->rm1', 'PATH_INFO translated'); } BEGIN { $COUNT += 2 } # prefix is added correctly { $response = GET('/app2/module_name/rm1'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm1', 'prefix added'); } BEGIN { $COUNT += 2 } # grab the RM correctly from the PATH_INFO { $response = GET('/app2/module_name/rm2'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm2', 'extract RM form PATH_INFO'); } BEGIN { $COUNT += 4 } # CGIAPP_DISPATCH_DEFAULT is used correctly { # no extra path $response = GET('/app3'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm2'); # only a '/' as the path_info $response = GET('/app3/'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm2', 'CGIAPP_DISPATCH_DEFAULT used'); } BEGIN { $COUNT += 2 } # override translate_module_name() { $response = GET('/app4/something_strange'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm1', 'override translate_module_name()'); } BEGIN { $COUNT += 8 } # cause errors { # non existant module $response = GET('/app2/asdf/rm1'); ok($response->is_error); cmp_ok($response->code, 'eq', '404', 'not found - no module'); # poorly written module $response = GET('/app2/module_bad/rm1'); ok($response->is_error); cmp_ok($response->code, 'eq', '500', 'server error: module doesnt compile'); # non existant run mode $response = GET('/app2/module_name/rm6'); ok($response->is_error); cmp_ok($response->code, 'eq', '404', 'not found: no run mode'); # invalid characters $response = GET('/app2/module;_bad'); ok($response->is_error); cmp_ok($response->code, 'eq', '400', 'server error: invalid characters'); } BEGIN { $COUNT += 27 } # dispatch table via a subclass { $response = GET('/app5/module_name'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm1', 'matched :app'); contains_string($content, 'hum=electra_200'); $response = GET('/app5/module_name/rm2'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm2', 'matched :app/:rm'); contains_string($content, 'hum=electra_200'); $response = GET('/app5/module_name/rm3/stuff'); ok($response->is_success); $content = $response->content; contains_string( $content, 'MyApp::Module::Name->rm3 my_param=stuff', 'matched :app/:rm/:my_param' ); contains_string($content, 'hum=electra_200'); $response = GET('/app5/module_name/bar/stuff'); ok($response->is_success); $content = $response->content; contains_string( $content, 'MyApp::Module::Name->rm3 my_param=stuff', 'matched :app/bar/:my_param' ); contains_string($content, 'hum=electra_200'); $response = GET('/app5/foo/bar'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm2', 'matched foo/bar'); contains_string($content, 'hum=electra_200'); $response = GET('/app5/module_name/foo'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm3 my_param=', 'missing optional'); contains_string($content, 'hum=electra_200'); $response = GET('/app5/module_name/foo/weird%20stuff'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm3 my_param=weird stuff', 'present optional'); contains_string($content, 'hum=electra_200'); $response = GET('/app5'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm1', 'empty default'); contains_string($content, 'hum=electra_200'); $response = GET('/app5/'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Name->rm1', 'empty default'); contains_string($content, 'hum=electra_200'); } BEGIN { $COUNT += 14 } # http method dispatching { $response = GET('/http_method/module_rest/rm1'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Rest->rm1_GET', 'auto_rest GET'); $response = POST('/http_method/module_rest/rm1'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Rest->rm1_POST', 'auto_rest POST'); $response = POST('/http_method/module_rest/rm2'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Rest->rm2_post', 'auto_rest_lc POST'); $response = GET('/http_method/module_rest/rm3'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Rest->get_rm3', 'HTTP method in rule'); $response = GET('/http_method/module_rest/rm4'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Rest->rm4', 'non-auto_rest GET'); lacks_string($content, 'MyApp::Module::Rest->rm4_GET', 'non-auto_rest GET'); $response = POST('/http_method/module_rest/rm4'); ok($response->is_success); $content = $response->content; contains_string($content, 'MyApp::Module::Rest->rm4', 'non-auto_rest POST'); lacks_string($content, 'MyApp::Module::Rest->rm4_POST', 'non-auto_rest POST'); } sub contains_string { my ($str, $substr, $diag) = @_; if(index($str, $substr) != -1) { ok(1); } else { ok(0); } } sub lacks_string { my ($str, $substr, $diag) = @_; if(index($str, $substr) != -1) { ok(0); } else { ok(1); } } CGI-Application-Dispatch-3.12/t/conf000755001750001750 012024502644 16275 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/t/conf/extra.conf.in000444001750001750 134112024502644 21030 0ustar00markmark000000000000 SetHandler perl-script PerlHandler CGI::Application::Dispatch SetHandler perl-script PerlHandler CGI::Application::Dispatch PerlSetVar CGIAPP_DISPATCH_PREFIX MyApp SetHandler perl-script PerlHandler CGI::Application::Dispatch PerlSetVar CGIAPP_DISPATCH_PREFIX MyApp PerlSetVar CGIAPP_DISPATCH_DEFAULT /module_name/rm2 SetHandler perl-script PerlHandler MyApp::Dispatch SetHandler perl-script PerlHandler MyApp::DispatchTable SetHandler perl-script PerlHandler MyApp::DispatchRest CGI-Application-Dispatch-3.12/t/conf/modperl_extra.pl000444001750001750 14012024502644 21607 0ustar00markmark000000000000# for development #use Devel::Cover ('+select' => 'CGI/Application/Dispatch', '+silent'); 1; CGI-Application-Dispatch-3.12/t/lib000755001750001750 012024502644 16116 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/t/lib/MyApp000755001750001750 012024502644 17144 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/t/lib/MyApp/DispatchPSGI.pm000444001750001750 31412024502644 22037 0ustar00markmark000000000000package MyApp::DispatchPSGI; use base 'CGI::Application::Dispatch::PSGI'; sub translate_module_name { my $self = shift; return 'MyApp::Module::Name'; } sub get_runmode { return 'rm2'; } 1; CGI-Application-Dispatch-3.12/t/lib/MyApp/DispatchTable.pm000444001750001750 143312024502644 22347 0ustar00markmark000000000000package MyApp::DispatchTable; use base 'CGI::Application::Dispatch'; sub dispatch_args { return { prefix => 'MyApp', table => [ 'foo/bar' => { app => 'Name', rm => 'rm2', prefix => 'MyApp::Module' }, ':app/bar/:my_param' => { rm => 'rm3' }, ':app/foo/:my_param?' => { rm => 'rm3' }, ':app/baz/*' => { rm => 'rm5' }, ':app/bap/*' => { rm => 'rm5', '*' => 'the_rest' }, ':app/:rm/:my_param' => { }, ':app/:rm' => { }, ':app' => { }, '' => { app => 'Module::Name', rm => 'rm1' }, ], args_to_new => { PARAMS => { hum => 'electra_2000' }, }, }; } 1; CGI-Application-Dispatch-3.12/t/lib/MyApp/DispatchTablePSGI.pm000444001750001750 144512024502644 23035 0ustar00markmark000000000000package MyApp::DispatchTablePSGI; use base 'CGI::Application::Dispatch::PSGI'; sub dispatch_args { return { prefix => 'MyApp', table => [ 'foo/bar' => { app => 'Name', rm => 'rm2', prefix => 'MyApp::Module' }, ':app/bar/:my_param' => { rm => 'rm3' }, ':app/foo/:my_param?' => { rm => 'rm3' }, ':app/baz/*' => { rm => 'rm5' }, ':app/bap/*' => { rm => 'rm5', '*' => 'the_rest' }, ':app/:rm/:my_param' => { }, ':app/:rm' => { }, ':app' => { }, '' => { app => 'Module::Name', rm => 'rm1' }, ], args_to_new => { PARAMS => { hum => 'electra_2000' }, }, }; } 1; CGI-Application-Dispatch-3.12/t/lib/MyApp/Dispatch.pm000444001750001750 30212024502644 21351 0ustar00markmark000000000000package MyApp::Dispatch; use base 'CGI::Application::Dispatch'; sub translate_module_name { my $self = shift; return 'MyApp::Module::Name'; } sub get_runmode { return 'rm2'; } 1; CGI-Application-Dispatch-3.12/t/lib/MyApp/DispatchRest.pm000444001750001750 66612024502644 22224 0ustar00markmark000000000000package MyApp::DispatchRest; use base 'CGI::Application::Dispatch'; sub dispatch_args { return { auto_rest => 1, prefix => 'MyApp', table => [ ':app/rm3[get]' => { rm => 'get_rm3', auto_rest => 0 }, ':app/rm4' => { auto_rest => 0, rm => 'rm4' }, ':app/rm2' => { auto_rest_lc => 1, rm => 'rm2' }, ':app/:rm' => { }, ], }; } 1; CGI-Application-Dispatch-3.12/t/lib/MyApp/Module000755001750001750 012024502644 20371 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/t/lib/MyApp/Module/Bad.pm000444001750001750 7312024502644 21512 0ustar00markmark000000000000package MyApp::Module::Name; use base 'CGI::Application'; CGI-Application-Dispatch-3.12/t/lib/MyApp/Module/Rest.pm000444001750001750 121712024502644 22002 0ustar00markmark000000000000package MyApp::Module::Rest; use base 'CGI::Application'; sub setup { my $self = shift; $self->start_mode('rm1_GET'); $self->run_modes([qw/ rm1_GET rm1_POST rm2_post get_rm3 rm4 /]); } sub rm1_GET { my $self = shift; return 'MyApp::Module::Rest->rm1_GET'; } sub rm1_POST { my $self = shift; return 'MyApp::Module::Rest->rm1_POST'; } sub rm2_post { my $self = shift; return 'MyApp::Module::Rest->rm2_post'; } sub get_rm3 { my $self = shift; return 'MyApp::Module::Rest->get_rm3'; } sub rm4 { my $self = shift; return 'MyApp::Module::Rest->rm4'; } 1; CGI-Application-Dispatch-3.12/t/lib/MyApp/Module/Name.pm000444001750001750 325612024502644 21752 0ustar00markmark000000000000package MyApp::Module::Name; use base 'CGI::Application'; use HTTP::Exception; sub setup { my $self = shift; $self->start_mode('rm1'); $self->run_modes([qw/ rm1 rm2 rm3 rm4 rm5 local_args_to_new throw_http_exception /]); $self->error_mode('rethrow_http_exceptions'); } sub rm1 { my $self = shift; return 'MyApp::Module::Name->rm1' . ($self->param('hum') ? 'hum=' . $self->param('hum') : ''); } sub rm2 { my $self = shift; return 'MyApp::Module::Name->rm2' . ($self->param('hum') ? 'hum=' . $self->param('hum') : ''); } sub rm3 { my $self = shift; my $param = $self->param('my_param') || ''; return "MyApp::Module::Name->rm3 my_param=$param" . ($self->param('hum') ? 'hum=' . $self->param('hum') : ''); } # because of caching, we can't re-use PATH_INFO, so we do this. sub rm4 { my $self = shift; return $self->rm3; } sub rm5 { my $self = shift; my $return=""; if( $self->param('the_rest') ) { $return = 'the_rest=' . $self->param('the_rest'); } else { $return = 'dispatch_url_remainder=' . $self->param('dispatch_url_remainder'); } return "MyApp::Module::Name->rm5 $return"; } sub local_args_to_new { my $self = shift; return $self->tmpl_path; } sub throw_http_exception { HTTP::Exception->throw(405, status_message => 'my 405 exception!'); } sub rethrow_http_exceptions { my $self = shift; my $e = shift; # Duck-type to see if we have an HTTP::Exception if (defined $e && $e->can('status_method')) { die $e; } # In this case, just die then, too... else { die $e; } } 1; CGI-Application-Dispatch-3.12/t/lib/Module000755001750001750 012024502644 17343 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/t/lib/Module/Name.pm000444001750001750 36112024502644 20676 0ustar00markmark000000000000package Module::Name; use base 'CGI::Application'; sub setup { my $self = shift; $self->start_mode('rm1'); $self->run_modes( rm1 => 'rm1', ); } sub rm1 { my $self = shift; return 'Module::Name->rm1'; } 1; CGI-Application-Dispatch-3.12/lib000755001750001750 012024502644 15653 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/lib/CGI000755001750001750 012024502644 16255 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/lib/CGI/Application000755001750001750 012024502644 20520 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/lib/CGI/Application/Dispatch.pm000444001750001750 12243412024502644 23020 0ustar00markmark000000000000package CGI::Application::Dispatch; use strict; use warnings; use Carp 'carp'; use Try::Tiny; our $VERSION = '3.12'; our $DEBUG = 0; BEGIN { use constant IS_MODPERL => exists($ENV{MOD_PERL}); use constant IS_MODPERL2 => (IS_MODPERL() and exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} == 2); if(IS_MODPERL2()) { require Apache2::RequestUtil; require Apache2::RequestRec; require APR::Table; require Apache2::Const; Apache2::Const->import(qw(OK SERVER_ERROR HTTP_BAD_REQUEST NOT_FOUND REDIRECT)); } elsif(IS_MODPERL()) { require Apache::Constants; Apache::Constants->import(qw(OK SERVER_ERROR BAD_REQUEST NOT_FOUND REDIRECT)); } } # these return values have different values used in different ENV use Exception::Class ( 'CGI::Application::Dispatch::Exception', 'CGI::Application::Dispatch::ERROR' => { isa => 'CGI::Application::Dispatch::Exception', alias => 'throw_error', description => 500, }, 'CGI::Application::Dispatch::NOT_FOUND' => { isa => 'CGI::Application::Dispatch::Exception', alias => 'throw_not_found', description => 404, }, 'CGI::Application::Dispatch::BAD_REQUEST' => { isa => 'CGI::Application::Dispatch::Exception', alias => 'throw_bad_request', description => 400, }, ); =pod =head1 NAME CGI::Application::Dispatch - Dispatch requests to CGI::Application based objects =head1 SYNOPSIS =head2 Out of Box Under mod_perl: SetHandler perl-script PerlHandler CGI::Application::Dispatch Under normal cgi: This would be the instance script for your application, such as /cgi-bin/dispatch.cgi: #!/usr/bin/perl use FindBin::Real 'Bin'; use lib Bin() . '/../../rel/path/to/my/perllib'; use CGI::Application::Dispatch; CGI::Application::Dispatch->dispatch(); =head2 With a dispatch table package MyApp::Dispatch; use base 'CGI::Application::Dispatch'; sub dispatch_args { return { prefix => 'MyApp', table => [ '' => { app => 'Welcome', rm => 'start' }, ':app/:rm' => { }, 'admin/:app/:rm' => { prefix => 'MyApp::Admin' }, ], }; } Under mod_perl: SetHandler perl-script PerlHandler MyApp::Dispatch Under normal cgi: This would be the instance script for your application, such as /cgi-bin/dispatch.cgi: #!/usr/bin/perl use FindBin::Real 'Bin'; use lib Bin() . '/../../rel/path/to/my/perllib'; use MyApp::Dispatch; MyApp::Dispatch->dispatch(); =head1 DESCRIPTION This module provides a way (as a mod_perl handler or running under vanilla CGI) to look at the path (as returned by L) of the incoming request, parse off the desired module and its run mode, create an instance of that module and run it. It currently supports both generations of mod_perl (1.x and 2.x). Although, for simplicity, all examples involving Apache configuration and mod_perl code will be shown using mod_perl 1.x. This may change as mp2 usage increases. It will translate a URI like this (under mod_perl): /app/module_name/run_mode or this (vanilla cgi) /app/index.cgi/module_name/run_mode into something that will be functionally similar to this my $app = Module::Name->new(..); $app->mode_param(sub {'run_mode'}); #this will set the run mode =head1 METHODS =head2 dispatch(%args) This is the primary method used during dispatch. Even under mod_perl, the L method uses this under the hood. #!/usr/bin/perl use strict; use CGI::Application::Dispatch; CGI::Application::Dispatch->dispatch( prefix => 'MyApp', default => 'module_name', ); This method accepts the following name value pairs: =over =item default Specify a value to use for the path if one is not available. This could be the case if the default page is selected (eg: "/" ). =item prefix This option will set the string that will be prepended to the name of the application module before it is loaded and created. So to use our previous example request of /app/index.cgi/module_name/run_mode This would by default load and create a module named 'Module::Name'. But let's say that you have all of your application specific modules under the 'My' namespace. If you set this option to 'My' then it would instead load the 'My::Module::Name' application module instead. =item args_to_new This is a hash of arguments that are passed into the C constructor of the application. =item table In most cases, simply using Dispatch with the C and C is enough to simplify your application and your URLs, but there are many cases where you want more power. Enter the dispatch table. Since this table can be slightly complicated, a whole section exists on its use. Please see the L section. =item debug Set to a true value to send debugging output for this module to STDERR. Off by default. =item error_document This string is similar to Apache ErrorDocument directive. If this value is not present, then Dispatch will return a NOT FOUND error either to the browser with simple hardcoded message (under CGI) or to Apache (under mod_perl). This value can be one of the following: B - if it starts with a single double-quote character (C<">). This double-quote character will be trimmed from final output. B - if it starts with less-than sign (C<<>). First character will be excluded as well. Path of this file should be relative to server DOCUMENT_ROOT. B - if no leading C<"> or C<<> will be found. Custom messages will be displayed I. (Under mod_perl, please use ErrorDocument directive in Apache configuration files.) This value can contain C<%s> placeholder for L Perl function. This placeholder will be replaced with numeric HTTP error code. Currently CGI::Application::Dispatch uses three HTTP errors: B<400 Bad Request> - If there are invalid characters in module name (parameter :app) or runmode name (parameter :rm). B<404 Not Found> - When the path does not match anything in the L, or module could not be found in @INC, or run mode did not exist. B<500 Internal Server Error> - If application error occurs. Examples of using error_document (assume error 404 have been returned): # return in browser 'Opss... HTTP Error #404' error_document => '"Opss... HTTP Error #%s' # return contents of file $ENV{DOCUMENT_ROOT}/errors/error404.html error_document => ' '/errors/error%s.html' # external redirect to # http://host.domain/cgi-bin/errors.cgi?error=404 error_document => 'http://host.domain/cgi-bin/errors.cgi?error=%s' =item auto_rest This tells Dispatch that you are using REST by default and that you care about which HTTP method is being used. Dispatch will append the HTTP method name (upper case by default) to the run mode that is determined after finding the appropriate dispatch rule. So a GET request that translates into C<< MyApp::Module->foo >> will become C<< MyApp::Module->foo_GET >>. This can be overridden on a per-rule basis in a custom dispatch table. =item auto_rest_lc In combinaion with L this tells Dispatch that you prefer lower cased HTTP method names. So instead of C and C you'll have C and C. =back =cut sub dispatch { my ($self, %args) = @_; # merge dispatch_args() and %args with %args taking precendence my $dispatch_args = $self->dispatch_args(\%args); for my $arg (keys %$dispatch_args) { # args_to_new should be merged if($arg eq 'args_to_new') { $args{args_to_new} ||= {}; # merge the PARAMS hash if($dispatch_args->{args_to_new}->{PARAMS}) { # merge the hashes $args{args_to_new}->{PARAMS} = { %{$dispatch_args->{args_to_new}->{PARAMS}}, %{$args{args_to_new}->{PARAMS} || {}}, }; } # combine any TMPL_PATHs if($dispatch_args->{args_to_new}->{TMPL_PATH}) { # make sure the orginial is an array ref if($args{args_to_new}->{TMPL_PATH}) { if(!ref $args{args_to_new}->{TMPL_PATH}) { $args{args_to_new}->{TMPL_PATH} = [$args{args_to_new}->{TMPL_PATH}]; } } else { $args{args_to_new}->{TMPL_PATH} = []; } # now add the rest to the end if(ref $dispatch_args->{args_to_new}->{TMPL_PATH}) { push( @{$args{args_to_new}->{TMPL_PATH}}, @{$dispatch_args->{args_to_new}->{TMPL_PATH}}, ); } else { push( @{$args{args_to_new}->{TMPL_PATH}}, $dispatch_args->{args_to_new}->{TMPL_PATH}, ); } } # now merge the args_to_new hashes $args{args_to_new} = {%{$dispatch_args->{args_to_new}}, %{$args{args_to_new}},}; } else { # anything else should override $args{$arg} = $dispatch_args->{$arg} unless exists $args{$arg}; } } $DEBUG = $args{debug} ? 1 : 0; # check for extra args (for backwards compatibility) for (keys %args) { next if( $_ eq 'prefix' or $_ eq 'default' or $_ eq 'debug' or $_ eq 'rm' or $_ eq 'args_to_new' or $_ eq 'table' or $_ eq 'auto_rest' or $_ eq 'auto_rest_lc' or $_ eq 'not_found' or $_ eq 'error_document'); carp "Passing extra args ('$_') to dispatch() is deprecated! Please use 'args_to_new'"; $args{args_to_new}->{$_} = delete $args{$_}; } # TODO: delete this block some time later if(exists $args{not_found}) { carp 'Passing not_found to dispatch() is deprecated! Please use error_document instead'; $args{error_document} = delete($args{not_found}) unless exists($args{error_document}); } %args = map { lc $_ => $args{$_} } keys %args; # lc for backwards # compatability # get the PATH_INFO my $path_info = $self->dispatch_path(); # use the 'default' if we need to $path_info = $args{default} || '' if(!$path_info || $path_info eq '/'); # make sure they all start and end with a '/', to correspond with # the RE we'll make $path_info = "/$path_info" unless(index($path_info, '/') == 0); $path_info = "$path_info/" unless(substr($path_info, -1) eq '/'); my ($module, $rm, $local_prefix, $local_args_to_new, $output); # take args from path my $named_args; try { $named_args = $self->_parse_path($path_info, $args{table}) or throw_not_found("Resource not found"); } catch { $output = $self->http_error($_, $args{error_document}); }; return $output if $output; if($DEBUG) { require Data::Dumper; warn "[Dispatch] Named args from match: " . Data::Dumper::Dumper($named_args) . "\n"; } # eval and catch any exceptions that might be thrown try { if(exists($named_args->{PARAMS}) || exists($named_args->{TMPL_PATH})) { carp "PARAMS and TMPL_PATH are not allowed here. Did you mean to use args_to_new?"; throw_error("PARAMS and TMPL_PATH not allowed"); } ($module, $local_prefix, $rm, $local_args_to_new) = delete @{$named_args}{qw(app prefix rm args_to_new)}; # If another name for dispatch_url_remainder has been set move # the value to the requested name if($$named_args{'*'}) { $$named_args{$$named_args{'*'}} = $$named_args{'dispatch_url_remainder'}; delete $$named_args{'*'}; delete $$named_args{'dispatch_url_remainder'}; } $module or throw_error("App not defined"); $module = $self->translate_module_name($module); $local_prefix ||= $args{prefix}; $module = $local_prefix . '::' . $module if($local_prefix); $local_args_to_new ||= $args{args_to_new}; # add the rest of the named_args to PARAMS @{$local_args_to_new->{PARAMS}}{keys %$named_args} = values %$named_args; my $auto_rest = defined $named_args->{auto_rest} ? $named_args->{auto_rest} : $args{auto_rest}; if($auto_rest && defined $rm && length $rm) { my $method_lc = defined $named_args->{auto_rest_lc} ? $named_args->{auto_rest_lc} : $args{auto_rest_lc}; my $http_method = $self->_http_method; $http_method = lc $http_method if $method_lc; $rm .= "_$http_method"; } # load and run the module $self->require_module($module); $output = $self->_run_app($module, $rm, $local_args_to_new); } catch { my $e = $_; unless ( ref $e && $e->isa('Exception::Class::Base') ) { $e = Exception::Class::Base->new($e); } $output = $self->http_error($e, $args{error_document}); }; return $output; } =pod =head2 dispatch_path() This method returns the path that is to be processed. By default it returns the value of C<$ENV{PATH_INFO}> (or C<< $r->path_info >> under mod_perl) which should work for most cases. It allows the ability for subclasses to override the value if they need to do something more specific. =cut sub dispatch_path { return $ENV{PATH_INFO}; } sub http_error { my ($self, $e, $errdoc) = @_; warn '[Dispatch] ERROR' . ($ENV{REQUEST_URI} ? " for request '$ENV{REQUEST_URI}': " : ': ') . $e->error . "\n"; my $errno = $e->isa('CGI::Application::Dispatch::Exception') ? $e->description : 500; my ($url, $output); if($errdoc) { my $str = sprintf($errdoc, $errno); if(IS_MODPERL) { #compile out all other stuff $url = $str; # no messages, please } elsif(index($str, '"') == 0) { # Error message $output = substr($str, 1); } elsif(index($str, '<') == 0) { # Local file # Is it secure? require File::Spec; $str = File::Spec->catdir($ENV{DOCUMENT_ROOT}, substr($str, 1)); local *FH; if(-f $str && open(FH, '<', $str)) { local $/ = undef; $output = ; close FH; } else { warn "[Dispatch] Error opening error document '$str'.\n"; } } else { # Last case is url $url = $str; } if($DEBUG) { warn "[Dispatch] Redirection for HTTP error #$errno to $url\n" if $url; warn "[Dispatch] Displaying message for HTTP error #$errno\n" if $output; } } # if we're under mod_perl if(IS_MODPERL) { my $r = $self->_r; $r->status($errno); # if we just want to redirect $r->headers_out->{'Location'} = $url if $url; return ''; } else { # else print the HTTP stuff ourselves # stolen from http_protocol.c in Apache sources # we don't actually use anything other than 200, 307, 400, 404 and 500 my %status_lines = ( # 100 => 'Continue', # 101 => 'Switching Protocols', # 102 => 'Processing', 200 => 'OK', # 201 => 'Created', # 202 => 'Accepted', # 203 => 'Non-Authoritative Information', # 204 => 'No Content', # 205 => 'Reset Content', # 206 => 'Partial Content', # 207 => 'Multi-Status', # 300 => 'Multiple Choices', # 301 => 'Moved Permanently', # 302 => 'Found', # 303 => 'See Other', # 304 => 'Not Modified', # 305 => 'Use Proxy', 307 => 'Temporary Redirect', 400 => 'Bad Request', # 401 => 'Authorization Required', # 402 => 'Payment Required', # 403 => 'Forbidden', 404 => 'Not Found', # 405 => 'Method Not Allowed', # 406 => 'Not Acceptable', # 407 => 'Proxy Authentication Required', # 408 => 'Request Time-out', # 409 => 'Conflict', # 410 => 'Gone', # 411 => 'Length Required', # 412 => 'Precondition Failed', # 413 => 'Request Entity Too Large', # 414 => 'Request-URI Too Large', # 415 => 'Unsupported Media Type', # 416 => 'Requested Range Not Satisfiable', # 417 => 'Expectation Failed', # 422 => 'Unprocessable Entity', # 423 => 'Locked', # 424 => 'Failed Dependency', 500 => 'Internal Server Error', # 501 => 'Method Not Implemented', # 502 => 'Bad Gateway', # 503 => 'Service Temporarily Unavailable', # 504 => 'Gateway Time-out', # 505 => 'HTTP Version Not Supported', # 506 => 'Variant Also Negotiates', # 507 => 'Insufficient Storage', # 510 => 'Not Extended', ); $errno = 500 if(!exists $status_lines{$errno}); if($url) { # somewhat mailformed header, no errors in access.log, but browsers # display contents of $url document and old URI in address bar. $output = "HTTP/1.0 $errno $status_lines{$errno}\n"; $output .= "Location: $url\n\n"; } else { unless($output) { # TODO: possibly provide more feedback in a way that # is XSS safe. (I'm not sure that passing through the # raw ENV variable directly is safe.) #

We tried: $ENV{REQUEST_URI}

"; $output = qq( $errno $status_lines{$errno} ) . ( $DEBUG ? '

' . __PACKAGE__ . ' error!

' : '' ) . qq(

$status_lines{$errno}

) . ($ENV{SERVER_ADMIN} ? "($ENV{SERVER_ADMIN})" : '') . qq(

) . ($ENV{SERVER_SIGNATURE} || '') . qq(); } # Apache will report $errno in access.log my $header .= "Status: $errno $status_lines{$errno}\n"; # try to guess, what a crap we get here $header .= $output =~ /[$i]; # are we trying to dispatch based on HTTP_METHOD? my $http_method_regex = qr/\[([^\]]+)\]$/; if($rule =~ /$http_method_regex/) { my $http_method = $1; # go ahead to the next rule next unless lc($1) eq lc($self->_http_method); # remove the method portion from the rule $rule =~ s/$http_method_regex//; } # make sure they start and end with a '/' to match how # PATH_INFO is formatted $rule = "/$rule" unless(index($rule, '/') == 0); $rule = "$rule/" if(substr($rule, -1) ne '/'); my @names = (); # translate the rule into a regular expression, but remember # where the named args are # '/:foo' will become '/([^\/]*)' # and # '/:bar?' will become '/?([^\/]*)?' # and then remember which position it matches $rule =~ s{ (^|/) # beginning or a / (:([^/\?]+)(\?)?) # stuff in between }{ push(@names, $3); $1 . ($4 ? '?([^/]*)?' : '([^/]*)') }gxe; # '/*/' will become '/(.*)/$' the end / is added to the end of # both $rule and $path elsewhere if($rule =~ m{/\*/$}) { $rule =~ s{/\*/$}{/(.*)/\$}; push(@names, 'dispatch_url_remainder'); } warn "[Dispatch] Trying to match '${path}' against rule '$table->[$i]' using regex '${rule}'\n" if $DEBUG; # if we found a match, then run with it if(my @values = ($path =~ m#^$rule$#)) { warn "[Dispatch] Matched!\n" if $DEBUG; my %named_args = %{$table->[++$i]}; @named_args{@names} = @values if @names; return \%named_args; } } return; } sub _http_method { IS_MODPERL ? shift->_r->method : ($ENV{HTTP_REQUEST_METHOD} || $ENV{REQUEST_METHOD}); } sub _r { IS_MODPERL2 ? Apache2::RequestUtil->request: Apache->request; } sub _run_app { my ($self, $module, $rm, $args) = @_; if($DEBUG) { require Data::Dumper; warn "[Dispatch] Final args to pass to new(): " . Data::Dumper::Dumper($args) . "\n"; } if($rm) { # check runmode name ($rm) = ($rm =~ /^([a-zA-Z_][\w']+)$/); throw_bad_request("Invalid characters in runmode name") unless $rm; } # now create and run then application object warn "[Dispatch] creating instance of $module\n" if($DEBUG); my $output; eval { my $app = ref($args) eq 'HASH' ? $module->new($args) : $module->new(); $app->mode_param(sub { return $rm }) if($rm); $output = $app->run(); }; if($@) { # catch invalid run-mode stuff if(not ref $@ and $@ =~ /No such run mode/) { throw_not_found("RM '$rm' not found") # otherwise, just pass it up the chain } else { die $@; } } return $output; } =head2 handler() This method is used so that this module can be run as a mod_perl handler. When it creates the application module it passes the $r argument into the PARAMS hash of new() SetHandler perl-script PerlHandler CGI::Application::Dispatch PerlSetVar CGIAPP_DISPATCH_PREFIX MyApp PerlSetVar CGIAPP_DISPATCH_DEFAULT /module_name The above example would tell apache that any url beginning with /app will be handled by CGI::Application::Dispatch. It also sets the prefix used to create the application module to 'MyApp' and it tells CGI::Application::Dispatch that it shouldn't set the run mode but that it will be determined by the application module as usual (through the query string). It also sets a default application module to be used if there is no path. So, a url of C would create an instance of C. Using this method will add the Crequest> object to your application's C as 'r'. # inside your app my $request = $self->param('r'); If you need more customization than can be accomplished with just L and L, then it would be best to just subclass CGI::Application::Dispatch and override L since C uses L to do the heavy lifting. package MyApp::Dispatch; use base 'CGI::Application::Dispatch'; sub dispatch_args { return { prefix => 'MyApp', table => [ '' => { app => 'Welcome', rm => 'start' }, ':app/:rm' => { }, 'admin/:app/:rm' => { prefix => 'MyApp::Admin' }, ], args_to_new => { PARAMS => { foo => 'bar', baz => 'bam', }, } }; } 1; And then in your httpd.conf SetHandler perl-script PerlHandler MyApp::Dispatch =cut sub handler : method { my ($self, $r) = @_; # set the PATH_INFO $ENV{PATH_INFO} = $r->path_info(); # setup our args to dispatch() my %args; my $config_args = $r->dir_config(); for my $var (qw(DEFAULT PREFIX ERROR_DOCUMENT)) { my $dir_var = "CGIAPP_DISPATCH_$var"; $args{lc($var)} = $config_args->{$dir_var} if($config_args->{$dir_var}); } # add $r to the args_to_new's PARAMS $args{args_to_new}->{PARAMS}->{r} = $r; # set debug if we need to $DEBUG = 1 if($config_args->{CGIAPP_DISPATCH_DEBUG}); if($DEBUG) { require Data::Dumper; warn "[Dispatch] Calling dispatch() with the following arguments: " . Data::Dumper::Dumper(\%args) . "\n"; } $self->dispatch(%args); if($r->status == 404) { return NOT_FOUND(); } elsif($r->status == 500) { return SERVER_ERROR(); } elsif($r->status == 400) { return IS_MODPERL2() ? HTTP_BAD_REQUEST() : BAD_REQUEST(); } else { return OK(); } } =head2 dispatch_args() Returns a hashref of args that will be passed to L(). It will return the following structure by default. { prefix => '', args_to_new => {}, table => [ ':app' => {}, ':app/:rm' => {}, ], } This is the perfect place to override when creating a subclass to provide a richer dispatch L. When called, it receives 1 argument, which is a reference to the hash of args passed into L. =cut sub dispatch_args { my ($self, $args) = @_; return { default => ($args->{default} || ''), prefix => ($args->{prefix} || ''), args_to_new => ($args->{args_to_new} || {}), table => [ ':app' => {}, ':app/:rm' => {}, ], }; } =head2 translate_module_name($input) This method is used to control how the module name is translated from the matching section of the path (see L<"Path Parsing">). The main reason that this method exists is so that it can be overridden if it doesn't do exactly what you want. The following transformations are performed on the input: =over =item The text is split on '_'s (underscores) and each word has its first letter capitalized. The words are then joined back together and each instance of an underscore is replaced by '::'. =item The text is split on '-'s (hyphens) and each word has its first letter capitalized. The words are then joined back together and each instance of a hyphen removed. =back Here are some examples to make it even clearer: module_name => Module::Name module-name => ModuleName admin_top-scores => Admin::TopScores =cut sub translate_module_name { my ($self, $input) = @_; $input = join('::', map { ucfirst($_) } split(/_/, $input)); $input = join('', map { ucfirst($_) } split(/-/, $input)); return $input; } =head2 require_module($module_name) This class method is used internally by CGI::Application::Dispatch to take a module name (supplied by L) and require it in a secure fashion. It is provided as a public class method so that if you override other functionality of this module, you can still safely require user specified modules. If there are any problems requiring the named module, then we will C. CGI::Application::Dispatch->require_module('MyApp::Module::Name'); =cut sub require_module { my ($self, $module) = @_; $module or throw_not_found("Can't define module name"); #untaint the module name ($module) = ($module =~ /^([A-Za-z][A-Za-z0-9_\-\:\']+)$/); unless($module) { throw_bad_request("Invalid characters in module name"); } warn "[Dispatch] loading module $module\n" if($DEBUG); eval "require $module"; return unless $@; my $module_path = $module; $module_path =~ s/::/\//g; if($@ =~ /Can't locate $module_path.pm/) { throw_not_found("Can't find module $module"); } else { throw_error("Unable to load module '$module': $@"); } } 1; __END__ =head1 DISPATCH TABLE Sometimes it's easiest to explain with an example, so here you go: CGI::Application::Dispatch->dispatch( prefix => 'MyApp', args_to_new => { TMPL_PATH => 'myapp/templates' }, table => [ '' => { app => 'Blog', rm => 'recent'}, 'posts/:category' => { app => 'Blog', rm => 'posts' }, ':app/:rm/:id' => { app => 'Blog' }, 'date/:year/:month?/:day?' => { app => 'Blog', rm => 'by_date', args_to_new => { TMPL_PATH => "events/" }, }, ] ); So first, this call to L sets the L and passes a C into L. Next it sets the L
. =head2 VOCABULARY Just so we all understand what we're talking about.... A table is an array where the elements are gouped as pairs (similar to a hash's key-value pairs, but as an array to preserve order). The first element of each pair is called a C. The second element in the pair is called the rule's C. Inside a rule there are slashes C. Anything set of characters between slashes is called a C. =head2 URL MATCHING When a URL comes in, Dispatch tries to match it against each rule in the table in the order in which the rules are given. The first one to match wins. A rule consists of slashes and tokens. A token can one of the following types: =over =item literal Any token which does not start with a colon (C<:>) is taken to be a literal string and must appear exactly as-is in the URL in order to match. In the rule 'posts/:category' C is a literal token. =item variable Any token which begins with a colon (C<:>) is a variable token. These are simply wild-card place holders in the rule that will match anything in the URL that isn't a slash. These variables can later be referred to by using the C<< $self->param >> mechanism. In the rule 'posts/:category' C<:category> is a variable token. If the URL matched this rule, then you could retrieve the value of that token from whithin your application like so: my $category = $self->param('category'); There are some variable tokens which are special. These can be used to further customize the dispatching. =over =item :app This is the module name of the application. The value of this token will be sent to the L method and then prefixed with the L if there is one. =item :rm This is the run mode of the application. The value of this token will be the actual name of the run mode used. The run mode can be optional, as noted below. Example: /foo/:rm? If no run mode is found, it will default to using the C<< start_mode() >>, just like invoking CGI::Application directly. Both of these URLs would end up dispatching to the start mode associated with /foo: /foo/ /foo =back =item optional-variable Any token which begins with a colon (C<:>) and ends with a question mark () is considered optional. If the rest of the URL matches the rest of the rule, then it doesn't matter whether it contains this token or not. It's best to only include optional-variable tokens at the end of your rule. In the rule 'date/:year/:month?/:day?' C<:month?> and C<:day?> are optional-variable tokens. Just like with L tokens, optional-variable tokens' values can also be retrieved by the application, if they existed in the URL. if( defined $self->param('month') ) { ... } =item wildcard The wildcard token "*" allows for partial matches. The token MUST appear at the end of the rule. 'posts/list/*' By default, the C param is set to the remainder of the URL matched by the *. The name of the param can be changed by setting "*" argument in the L. 'posts/list/*' => { '*' => 'post_list_filter' } =item method You can also dispatch based on HTTP method. This is similar to using L but offers more fine grained control. You include the method (case insensitive) at the end of the rule and enclose it in square brackets. ':app/news[post]' => { rm => 'add_news' }, ':app/news[get]' => { rm => 'news' }, ':app/news[delete]' => { rm => 'delete_news' }, =back The main reason that we don't use regular expressions for dispatch rules is that regular expressions provide no mechanism for named back references, like variable tokens do. =head2 ARG LIST Each rule can have an accompanying arg-list. This arg list can contain special arguments that override something set higher up in L for this particular URL, or just have additional args passed available in C<< $self->param() >> For instance, if you want to override L for a specific rule, then you can do so. 'admin/:app/:rm' => { prefix => 'MyApp::Admin' }, =head1 Path Parsing This section will describe how the application module and run mode are determined from the path if no L is present, and what options you have to customize the process. The value for the path to be parsed is retrieved from the L method, which by default uses the C environment variable. =head2 Getting the module name To get the name of the application module the path is split on backslahes (C). The second element of the returned list (the first is empty) is used to create the application module. So if we have a path of /module_name/mode1 then the string 'module_name' is used. This is passed through the L method. Then if there is a C (and there should always be a L) it is added to the beginning of this new module name with a double colon C<::> separating the two. If you don't like the exact way that this is done, don't fret you do have a couple of options. First, you can specify a L which is much more powerful and flexible (in fact this default behavior is actually implemented internally with a dispatch table). Or if you want something a little simpler, you can simply subclass and extend the L method. =head2 Getting the run mode Just like the module name is retrieved from splitting the path on slashes, so is the run mode. Only instead of using the second element of the resulting list, we use the third as the run mode. So, using the same example, if we have a path of /module_name/mode2 Then the string 'mode2' is used as the run mode. =head1 MISC NOTES =over 8 =item * CGI query strings CGI query strings are unaffected by the use of C to obtain the module name and run mode. This means that any other modules you use to get access to you query argument (ie, L, L) should not be affected. But, since the run mode may be determined by CGI::Application::Dispatch having a query argument named 'rm' will be ignored by your application module. =back =head1 CLEAN URLS WITH MOD_REWRITE With a dispatch script, you can fairly clean URLS like this: /cgi-bin/dispatch.cgi/module_name/run_mode However, including "/cgi-bin/dispatch.cgi" in ever URL doesn't add any value to the URL, so it's nice to remove it. This is easily done if you are using the Apache web server with C available. Adding the following to a C<.htaccess> file would allow you to simply use: /module_name/run_mode If you have problems with mod_rewrite, turn on debugging to see exactly what's happening: RewriteLog /home/project/logs/alpha-rewrite.log RewriteLogLevel 9 =head2 mod_rewrite related code in the dispatch script. This seemed necessary to put in the dispatch script to make mod_rewrite happy. Perhaps it's specific to using C. # mod_rewrite alters the PATH_INFO by turning it into a file system path, # so we repair it. $ENV{PATH_INFO} =~ s/^$ENV{DOCUMENT_ROOT}// if defined $ENV{PATH_INFO}; =head2 Simple Apache Example RewriteEngine On # You may want to change the base if you are using the dispatcher within a # specific directory. RewriteBase / # If an actual file or directory is requested, serve directly RewriteCond %{REQUEST_FILENAME} !-f RewriteCond %{REQUEST_FILENAME} !-d # Otherwise, pass everything through to the dispatcher RewriteRule ^(.*)$ /cgi-bin/dispatch.cgi/$1 [L,QSA] =head2 More complex rewrite: dispatching "/" and multiple developers Here is a more complex example that dispatches "/", which would otherwise be treated as a directory, and also supports multiple developer directories, so C has its own separate dispatching system beneath it. Note that order matters here! The Location block for "/" needs to come before the user blocks. RewriteEngine On RewriteBase / # Run "/" through the dispatcher RewriteRule ^home/project/www/$ /cgi-bin/dispatch.cgi [L,QSA] # Don't apply this rule to the users sub directories. RewriteCond %{REQUEST_URI} !^/~.*$ # If an actual file or directory is requested, serve directly RewriteCond %{REQUEST_FILENAME} !-f RewriteCond %{REQUEST_FILENAME} !-d # Otherwise, pass everything through to the dispatcher RewriteRule ^(.*)$ /cgi-bin/dispatch.cgi/$1 [L,QSA] RewriteEngine On RewriteBase /~mark # Run "/" through the dispatcher RewriteRule ^/home/mark/www/$ /~mark/cgi-bin/dispatch.cgi [L,QSA] # Otherwise, if an actual file or directory is requested, # serve directly RewriteCond %{REQUEST_FILENAME} !-f RewriteCond %{REQUEST_FILENAME} !-d # Otherwise, pass everything through to the dispatcher RewriteRule ^(.*)$ /~mark/cgi-bin/dispatch.cgi/$1 [L,QSA] # These examples may also be helpful, but are unrelated to dispatching. SetEnv DEVMODE mark SetEnv PERL5LIB /home/mark/perllib:/home/mark/config ErrorDocument 404 /~mark/errdocs/404.html ErrorDocument 500 /~mark/errdocs/500.html =head1 SUBCLASSING While Dispatch tries to be flexible, it won't be able to do everything that people want. Hopefully we've made it flexible enough so that if it doesn't do I you can easily subclass it. =cut #=head2 PROTECTED METHODS # #The following methods are intended to be overridden by subclasses if #necessary. They are not part of the public API since end users will #never touch them. However, to ensure that your subclass of Dispatch #does not break with a new release, they are documented here and are #considered to be part of the API and will not be changed without very #good reasons. =head1 AUTHOR Michael Peters Thanks to Plus Three, LP (http://www.plusthree.com) for sponsoring my work on this module =head1 COMMUNITY This module is a part of the larger L community. If you have questions or comments about this module then please join us on the cgiapp mailing list by sending a blank message to "cgiapp-subscribe@lists.erlbaum.net". There is also a community wiki located at L =head1 SOURCE CODE REPOSITORY A public source code repository for this project is hosted here: http://code.google.com/p/cgi-app-modules/source/checkout =head1 CONTRIBUTORS =over =item * Shawn Sorichetti =item * Timothy Appnel =item * dsteinbrunner =item * ZACKSE =item * Stew Heckenberg =item * Drew Taylor =item * James Freeman =item * Michael Graham =item * Cees Hek =item * Mark Stosberg =item * Viacheslav Sheveliov =back =head1 SECURITY Since C::A::Dispatch will dynamically choose which modules to use as the content generators, it may give someone the ability to execute random modules on your system if those modules can be found in you path. Of course those modules would have to behave like L based modules, but that still opens up the door more than most want. This should only be a problem if you don't use a L. By using this option you are only allowing Dispatch to pick from a namespace of modules to run. =head1 SEE ALSO L, L =head1 COPYRIGHT & LICENSE Copyright Michael Peters and Mark Stosberg 2008, all rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut CGI-Application-Dispatch-3.12/lib/CGI/Application/Dispatch000755001750001750 012024502644 22257 5ustar00markmark000000000000CGI-Application-Dispatch-3.12/lib/CGI/Application/Dispatch/PSGI.pm000444001750001750 10011612024502644 23553 0ustar00markmark000000000000package CGI::Application::Dispatch::PSGI; use strict; use warnings; use Carp 'carp'; use HTTP::Exception; our $VERSION = '3.12'; our $DEBUG = 0; =pod =head1 NAME CGI::Application::Dispatch::PSGI - Dispatch requests to CGI::Application based objects using PSGI =head1 SYNOPSIS =head2 Out of Box Under mod_perl: # change "Apache1" to "Apache2" as needed. SetHandler perl-script PerlHandler Plack::Handler::Apache1 PerlSetVar psgi_app /path/to/app.psgi use Plack::Handler::Apache1; Plack::Handler::Apache1->preload("/path/to/app.psgi"); Under CGI: This would be the instance script for your application, such as /cgi-bin/dispatch.cgi: ### in your dispatch.psgi: # ( in a persistent environment, use FindBin::Real instead. ) use FindBin 'Bin'; use lib "$Bin/../perllib'; use Your::Application::Dispatch; Your::Application::Dispatch->as_psgi; ### In Your::Application::Dispatch; package Your::Application::Dispatch; use base 'CGI::Application::Dispatch::PSGI'; =head2 With a dispatch table package MyApp::Dispatch; use base 'CGI::Application::Dispatch::PSGI'; sub dispatch_args { return { prefix => 'MyApp', table => [ '' => { app => 'Welcome', rm => 'start' }, ':app/:rm' => { }, 'admin/:app/:rm' => { prefix => 'MyApp::Admin' }, ], }; } The C<< .psgi >> file is constructed as above. =head2 With a custom query object If you want to supply your own PSGI object, something like this in your .psgi file will work: sub { my $env = shift; my $app = CGI::Application::Dispatch::PSGI->as_psgi( table => [ '/:rm' => { app => 'TestApp' } ], args_to_new => { QUERY => CGI::PSGI->new($env) } ); return $app->($env); } =head1 DESCRIPTION This module provides a way to look at the path (as returned by C<< $env->{PATH_INFO} >>) of the incoming request, parse off the desired module and its run mode, create an instance of that module and run it. It will translate a URI like this (in a persistent environment) /app/module_name/run_mode or this (vanilla CGI) /app/index.cgi/module_name/run_mode into something that will be functionally similar to this my $app = Module::Name->new(..); $app->mode_param(sub {'run_mode'}); #this will set the run mode =head1 METHODS =cut sub as_psgi { my ($self, %args) = @_; # merge dispatch_args() and %args with %args taking precendence my $dispatch_args = $self->dispatch_args(\%args); for my $arg (keys %$dispatch_args) { # args_to_new should be merged if($arg eq 'args_to_new') { $args{args_to_new} ||= {}; # merge the PARAMS hash if($dispatch_args->{args_to_new}->{PARAMS}) { # merge the hashes $args{args_to_new}->{PARAMS} = { %{$dispatch_args->{args_to_new}->{PARAMS}}, %{$args{args_to_new}->{PARAMS} || {}}, }; } # combine any TMPL_PATHs if($dispatch_args->{args_to_new}->{TMPL_PATH}) { # make sure the orginial is an array ref if($args{args_to_new}->{TMPL_PATH}) { if(!ref $args{args_to_new}->{TMPL_PATH}) { $args{args_to_new}->{TMPL_PATH} = [$args{args_to_new}->{TMPL_PATH}]; } } else { $args{args_to_new}->{TMPL_PATH} = []; } # now add the rest to the end if(ref $dispatch_args->{args_to_new}->{TMPL_PATH}) { push( @{$args{args_to_new}->{TMPL_PATH}}, @{$dispatch_args->{args_to_new}->{TMPL_PATH}}, ); } else { push( @{$args{args_to_new}->{TMPL_PATH}}, $dispatch_args->{args_to_new}->{TMPL_PATH}, ); } } # now merge the args_to_new hashes $args{args_to_new} = {%{$dispatch_args->{args_to_new}}, %{$args{args_to_new}},}; } else { # anything else should override $args{$arg} = $dispatch_args->{$arg} unless exists $args{$arg}; } } $DEBUG = $args{debug} ? 1 : 0; # check for extra args (for backwards compatibility) for (keys %args) { next if( $_ eq 'prefix' or $_ eq 'default' or $_ eq 'debug' or $_ eq 'rm' or $_ eq 'args_to_new' or $_ eq 'table' or $_ eq 'auto_rest' or $_ eq 'auto_rest_lc'); die "Passing extra args ('$_') to as_psgi() is not supported! Did you mean to use 'args_to_new' ?"; $args{args_to_new}->{$_} = delete $args{$_}; } return sub { my $env = shift; # get the PATH_INFO my $path_info = $env->{PATH_INFO}; # use the 'default' if we need to $path_info = $args{default} || '' if(!$path_info || $path_info eq '/'); # make sure they all start and end with a '/', to correspond # with the RE we'll make $path_info = "/$path_info" unless(index($path_info, '/') == 0); $path_info = "$path_info/" unless(substr($path_info, -1) eq '/'); my ($module, $rm, $local_prefix, $local_args_to_new); # take args from path my $named_args; eval { $named_args = $self->_parse_path($path_info, $args{table},$env) or HTTP::Exception->throw(404, status_message => 'Resource not found'); }; if (my $e = HTTP::Exception->caught) { return $self->http_error($e); } if($DEBUG) { require Data::Dumper; warn "[Dispatch] Named args from match: " . Data::Dumper::Dumper($named_args) . "\n"; } if(exists($named_args->{PARAMS}) || exists($named_args->{TMPL_PATH})) { carp "PARAMS and TMPL_PATH are not allowed here. Did you mean to use args_to_new?"; HTTP::Exception->throw(500, status_message => 'PARAMS and TMPL_PATH not allowed'); } # eval and catch any exceptions that might be thrown my ($output, @final_dispatch_args); my $psgi_app; eval { ($module, $local_prefix, $rm, $local_args_to_new) = delete @{$named_args}{qw(app prefix rm args_to_new)}; # If another name for dispatch_url_remainder has been set move # the value to the requested name if($$named_args{'*'}) { $$named_args{$$named_args{'*'}} = $$named_args{'dispatch_url_remainder'}; delete $$named_args{'*'}; delete $$named_args{'dispatch_url_remainder'}; } $module or HTTP::Exception->throw(500, status_message => 'App not defined'); $module = $self->translate_module_name($module); $local_prefix ||= $args{prefix}; $module = $local_prefix . '::' . $module if($local_prefix); $local_args_to_new ||= $args{args_to_new}; # add the rest of the named_args to PARAMS @{$local_args_to_new->{PARAMS}}{keys %$named_args} = values %$named_args; my $auto_rest = defined $named_args->{auto_rest} ? $named_args->{auto_rest} : $args{auto_rest}; if($auto_rest && defined $rm && length $rm) { my $method_lc = defined $named_args->{auto_rest_lc} ? $named_args->{auto_rest_lc} : $args{auto_rest_lc}; my $http_method = $env->{REQUEST_METHOD}; $http_method = lc $http_method if $method_lc; $rm .= "_$http_method"; } # load and run the module @final_dispatch_args = ($module, $rm, $local_args_to_new); $self->require_module($module); $psgi_app = $self->_run_app($module, $rm, $local_args_to_new,$env); }; if (my $e = HTTP::Exception->caught) { return $self->http_error($e); } elsif ($e = Exception::Class->caught) { ref $e ? $e->rethrow : die $e; } return $psgi_app; } } =head2 as_psgi(%args) This is the primary method used during dispatch. #!/usr/bin/perl use strict; use CGI::Application::Dispatch::PSGI; CGI::Application::Dispatch::PSGI->as_psgi( prefix => 'MyApp', default => 'module_name', ); This method accepts the following name value pairs: =over =item default Specify a value to use for the path if one is not available. This could be the case if the default page is selected (eg: "/" ). =item prefix This option will set the string that will be prepended to the name of the application module before it is loaded and created. So to use our previous example request of /app/index.cgi/module_name/run_mode This would by default load and create a module named 'Module::Name'. But let's say that you have all of your application specific modules under the 'My' namespace. If you set this option to 'My' then it would instead load the 'My::Module::Name' application module instead. =item args_to_new This is a hash of arguments that are passed into the C constructor of the application. =item table In most cases, simply using Dispatch with the C and C is enough to simplify your application and your URLs, but there are many cases where you want more power. Enter the dispatch table. Since this table can be slightly complicated, a whole section exists on its use. Please see the L section. =item debug Set to a true value to send debugging output for this module to STDERR. Off by default. =item auto_rest This tells Dispatch that you are using REST by default and that you care about which HTTP method is being used. Dispatch will append the HTTP method name (upper case by default) to the run mode that is determined after finding the appropriate dispatch rule. So a GET request that translates into C<< MyApp::Module->foo >> will become C<< MyApp::Module->foo_GET >>. This can be overridden on a per-rule basis in a custom dispatch table. =item auto_rest_lc In combinaion with L this tells Dispatch that you prefer lower cased HTTP method names. So instead of C and C you'll have C and C. =back =cut sub http_error { my ($self, $e) = @_; warn '[Dispatch] ERROR' . ($ENV{REQUEST_URI} ? " for request '$ENV{REQUEST_URI}': " : ': ') . $e->error . "\n"; my $errno = $e->isa('HTTP::Exception::Base') ? $e->code : 500; my $output = $e->isa('HTTP::Exception::Base') ? $e->status_message : "Internal Server Error"; # The custom status message was most useful for logging. Return # generic messages to the user. $output = 'Not Found' if ($e->code == 404); $output = 'Internal Server Error' if ($e->code == 500); return [ $errno, [], [ $output ] ]; } # protected method - designed to be used by sub classes, not by end users sub _parse_path { my ($self, $path, $table, $env) = @_; # get the module name from the table return unless defined($path); unless(ref($table) eq 'ARRAY') { warn "[Dispatch] Invalid or no dispatch table!\n"; return; } # look at each rule and stop when we get a match for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) { my $rule = $table->[$i]; # are we trying to dispatch based on HTTP_METHOD? my $http_method_regex = qr/\[([^\]]+)\]$/; if($rule =~ /$http_method_regex/) { my $http_method = $1; # go ahead to the next rule next unless lc($1) eq lc($env->{REQUEST_METHOD}); # remove the method portion from the rule $rule =~ s/$http_method_regex//; } # make sure they start and end with a '/' to match how # PATH_INFO is formatted $rule = "/$rule" unless(index($rule, '/') == 0); $rule = "$rule/" if(substr($rule, -1) ne '/'); my @names = (); # translate the rule into a regular expression, but remember # where the named args are # '/:foo' will become '/([^\/]*)' # and # '/:bar?' will become '/?([^\/]*)?' # and then remember which position it matches $rule =~ s{ (^|/) # beginning or a / (:([^/\?]+)(\?)?) # stuff in between }{ push(@names, $3); $1 . ($4 ? '?([^/]*)?' : '([^/]*)') }gxe; # '/*/' will become '/(.*)/$' the end / is added to the end of # both $rule and $path elsewhere if($rule =~ m{/\*/$}) { $rule =~ s{/\*/$}{/(.*)/\$}; push(@names, 'dispatch_url_remainder'); } warn "[Dispatch] Trying to match '${path}' against rule '$table->[$i]' using regex '${rule}'\n" if $DEBUG; # if we found a match, then run with it if(my @values = ($path =~ m#^$rule$#)) { warn "[Dispatch] Matched!\n" if $DEBUG; my %named_args = %{$table->[++$i]}; @named_args{@names} = @values if @names; return \%named_args; } } return; } sub _run_app { my ($self, $module, $rm, $args,$env) = @_; if($DEBUG) { require Data::Dumper; warn "[Dispatch] Final args to pass to new(): " . Data::Dumper::Dumper($args) . "\n"; } if($rm) { # check runmode name ($rm) = ($rm =~ /^([a-zA-Z_][\w']+)$/); HTTP::Exception->throw(400, status_message => "Invalid characters in runmode name") unless $rm; } # now create and run then application object warn "[Dispatch] creating instance of $module\n" if($DEBUG); my $psgi; eval { my $app = do { if (ref($args) eq 'HASH' and not defined $args->{QUERY}) { require CGI::PSGI; $args->{QUERY} = CGI::PSGI->new($env); $module->new($args); } elsif (ref($args) eq 'HASH') { $module->new($args); } else { $module->new(); } }; $app->mode_param(sub { return $rm }) if($rm); $psgi = $app->run_as_psgi; }; # App threw an HTTP::Exception? Cool. Bubble it up. my $e; if ($e = HTTP::Exception->caught) { $e->rethrow; } else { $e = Exception::Class->caught(); # catch invalid run-mode stuff if (not ref $e and $e =~ /No such run mode/) { HTTP::Exception->throw(404, status_message => "RM '$rm' not found"); } # otherwise, it's an internal server error. elsif (defined $e and length $e) { HTTP::Exception->throw(500, status_message => "Unknown error: $e"); #return $psgi; } else { # no exception return $psgi; } } } =head2 dispatch_args() Returns a hashref of args that will be passed to L(). It will return the following structure by default. { prefix => '', args_to_new => {}, table => [ ':app' => {}, ':app/:rm' => {}, ], } This is the perfect place to override when creating a subclass to provide a richer dispatch L
. When called, it receives 1 argument, which is a reference to the hash of args passed into L. =cut sub dispatch_args { my ($self, $args) = @_; return { default => ($args->{default} || ''), prefix => ($args->{prefix} || ''), args_to_new => ($args->{args_to_new} || {}), table => [ ':app' => {}, ':app/:rm' => {}, ], }; } =head2 translate_module_name($input) This method is used to control how the module name is translated from the matching section of the path (see L<"Path Parsing">. The main reason that this method exists is so that it can be overridden if it doesn't do exactly what you want. The following transformations are performed on the input: =over =item The text is split on '_'s (underscores) and each word has its first letter capitalized. The words are then joined back together and each instance of an underscore is replaced by '::'. =item The text is split on '-'s (hyphens) and each word has its first letter capitalized. The words are then joined back together and each instance of a hyphen removed. =back Here are some examples to make it even clearer: module_name => Module::Name module-name => ModuleName admin_top-scores => Admin::TopScores =cut sub translate_module_name { my ($self, $input) = @_; $input = join('::', map { ucfirst($_) } split(/_/, $input)); $input = join('', map { ucfirst($_) } split(/-/, $input)); return $input; } =head2 require_module($module_name) This class method is used internally to take a module name (supplied by L) and require it in a secure fashion. It is provided as a public class method so that if you override other functionality of this module, you can still safely require user specified modules. If there are any problems requiring the named module, then we will C. CGI::Application::Dispatch::PSGI->require_module('MyApp::Module::Name'); =cut sub require_module { my ($self, $module) = @_; $module or HTTP::Exception->throw(404, status_message => "Can't define module name"); #untaint the module name ($module) = ($module =~ /^([A-Za-z][A-Za-z0-9_\-\:\']+)$/); unless($module) { HTTP::Exception->throw(400, status_message => "Invalid characters in module name"); } warn "[Dispatch] loading module $module\n" if($DEBUG); eval "require $module"; return unless $@; my $module_path = $module; $module_path =~ s/::/\//g; if($@ =~ /Can't locate $module_path.pm/) { HTTP::Exception->throw(404, status_message => "Can't find module $module"); } else { HTTP::Exception->throw(500, status_message => "Unable to load module '$module': $@"); } } 1; __END__ =head1 DISPATCH TABLE Sometimes it's easiest to explain with an example, so here you go: CGI::Application::Dispatch::PSGI->as_psgi( prefix => 'MyApp', args_to_new => { TMPL_PATH => 'myapp/templates' }, table => [ '' => { app => 'Blog', rm => 'recent'}, 'posts/:category' => { app => 'Blog', rm => 'posts' }, ':app/:rm/:id' => { app => 'Blog' }, 'date/:year/:month?/:day?' => { app => 'Blog', rm => 'by_date', args_to_new => { TMPL_PATH => "events/" }, }, ] ); So first, this call to L sets the L and passes a C into L. Next it sets the L
. =head2 VOCABULARY Just so we all understand what we're talking about.... A table is an array where the elements are gouped as pairs (similar to a hash's key-value pairs, but as an array to preserve order). The first element of each pair is called a C. The second element in the pair is called the rule's C. Inside a rule there are slashes C. Anything set of characters between slashes is called a C. =head2 URL MATCHING When a URL comes in, Dispatch tries to match it against each rule in the table in the order in which the rules are given. The first one to match wins. A rule consists of slashes and tokens. A token can one of the following types: =over =item literal Any token which does not start with a colon (C<:>) is taken to be a literal string and must appear exactly as-is in the URL in order to match. In the rule 'posts/:category' C is a literal token. =item variable Any token which begins with a colon (C<:>) is a variable token. These are simply wild-card place holders in the rule that will match anything in the URL that isn't a slash. These variables can later be referred to by using the C<< $self->param >> mechanism. In the rule 'posts/:category' C<:category> is a variable token. If the URL matched this rule, then you could the value of that token from whithin your application like so: my $category = $self->param('category'); There are some variable tokens which are special. These can be used to further customize the dispatching. =over =item :app This is the module name of the application. The value of this token will be sent to the L method and then prefixed with the L if there is one. =item :rm This is the run mode of the application. The value of this token will be the actual name of the run mode used. The run mode can be optional, as noted below. Example: /foo/:rm? If no run mode is found, it will default to using the C<< start_mode() >>, just like invoking CGI::Application directly. Both of these URLs would end up dispatching to the start mode associated with /foo: /foo/ /foo =back =item optional-variable Any token which begins with a colon (C<:>) and ends with a question mark () is considered optional. If the rest of the URL matches the rest of the rule, then it doesn't matter whether it contains this token or not. It's best to only include optional-variable tokens at the end of your rule. In the rule 'date/:year/:month?/:day?' C<:month?> and C<:day?> are optional-variable tokens. Just like with L tokens, optional-variable tokens' values can also be retrieved by the application, if they existed in the URL. if( defined $self->param('month') ) { ... } =item wildcard The wildcard token "*" allows for partial matches. The token MUST appear at the end of the rule. 'posts/list/*' By default, the C param is set to the remainder of the URL matched by the *. The name of the param can be changed by setting "*" argument in the L. 'posts/list/*' => { '*' => 'post_list_filter' } =item method You can also dispatch based on HTTP method. This is similar to using L but offers more fine grained control. You include the method (case insensitive) at the end of the rule and enclose it in square brackets. ':app/news[post]' => { rm => 'add_news' }, ':app/news[get]' => { rm => 'news' }, ':app/news[delete]' => { rm => 'delete_news' }, =back The main reason that we don't use regular expressions for dispatch rules is that regular expressions provide no mechanism for named back references, like variable tokens do. =head2 ARG LIST Each rule can have an accompanying arg-list. This arg list can contain special arguments that override something set higher up in L for this particular URL, or just have additional args passed available in C<< $self->param() >> For instance, if you want to override L for a specific rule, then you can do so. 'admin/:app/:rm' => { prefix => 'MyApp::Admin' }, =head1 Path Parsing This section will describe how the application module and run mode are determined from the path if no L is present, and what options you have to customize the process. The value for the path to be parsed is retrieved from C<< $env->{PATH_INFO} >>. =head2 Getting the module name To get the name of the application module the path is split on backslahes (C). The second element of the returned list (the first is empty) is used to create the application module. So if we have a path of /module_name/mode1 then the string 'module_name' is used. This is passed through the L method. Then if there is a C (and there should always be a L) it is added to the beginning of this new module name with a double colon C<::> separating the two. If you don't like the exact way that this is done, don't fret you do have a couple of options. First, you can specify a L which is much more powerful and flexible (in fact this default behavior is actually implemented internally with a dispatch table). Or if you want something a little simpler, you can simply subclass and extend the L method. =head2 Getting the run mode Just like the module name is retrieved from splitting the path on slashes, so is the run mode. Only instead of using the second element of the resulting list, we use the third as the run mode. So, using the same example, if we have a path of /module_name/mode2 Then the string 'mode2' is used as the run mode. =head1 Exception Handling A CGI::Application object can throw an exception up to C<< CGI::Application::Dispatch::PSGI >> if no C is implemented or if the error_mode itself throws an exception. In these cases we generally return a generic "500" response, and log some details for the developer with a warning. However, we will check to see if the exception thrown is an HTTP::Exception object. If that's the case, we will rethrow it, and you can handle it yourself using something like L. =head1 MISC NOTES =over 8 =item * CGI query strings CGI query strings are unaffected by the use of C to obtain the module name and run mode. This means that any other modules you use to get access to you query argument (ie, L, L) should not be affected. But, since the run mode may be determined by CGI::Application::Dispatch::PSGI having a query argument named 'rm' will be ignored by your application module. =back =head1 CLEAN URLS WITH MOD_REWRITE With a dispatch script, you can fairly clean URLS like this: /cgi-bin/dispatch.cgi/module_name/run_mode However, including "/cgi-bin/dispatch.cgi" in ever URL doesn't add any value to the URL, so it's nice to remove it. This is easily done if you are using the Apache web server with C available. Adding the following to a C<.htaccess> file would allow you to simply use: /module_name/run_mode If you have problems with mod_rewrite, turn on debugging to see exactly what's happening: RewriteLog /home/project/logs/alpha-rewrite.log RewriteLogLevel 9 =head2 mod_rewrite related code in the dispatch script. This seemed necessary to put in the dispatch script to make mod_rewrite happy. Perhaps it's specific to using C. # mod_rewrite alters the PATH_INFO by turning it into a file system path, # so we repair it. $ENV{PATH_INFO} =~ s/^$ENV{DOCUMENT_ROOT}// if defined $ENV{PATH_INFO}; =head2 Simple Apache Example RewriteEngine On # You may want to change the base if you are using the dispatcher within a # specific directory. RewriteBase / # If an actual file or directory is requested, serve directly RewriteCond %{REQUEST_FILENAME} !-f RewriteCond %{REQUEST_FILENAME} !-d # Otherwise, pass everything through to the dispatcher RewriteRule ^(.*)$ /cgi-bin/dispatch.cgi/$1 [L,QSA] =head2 More complex rewrite: dispatching "/" and multiple developers Here is a more complex example that dispatches "/", which would otherwise be treated as a directory, and also supports multiple developer directories, so C has its own separate dispatching system beneath it. Note that order matters here! The Location block for "/" needs to come before the user blocks. RewriteEngine On RewriteBase / # Run "/" through the dispatcher RewriteRule ^home/project/www/$ /cgi-bin/dispatch.cgi [L,QSA] # Don't apply this rule to the users sub directories. RewriteCond %{REQUEST_URI} !^/~.*$ # If an actual file or directory is requested, serve directly RewriteCond %{REQUEST_FILENAME} !-f RewriteCond %{REQUEST_FILENAME} !-d # Otherwise, pass everything through to the dispatcher RewriteRule ^(.*)$ /cgi-bin/dispatch.cgi/$1 [L,QSA] RewriteEngine On RewriteBase /~mark # Run "/" through the dispatcher RewriteRule ^/home/mark/www/$ /~mark/cgi-bin/dispatch.cgi [L,QSA] # Otherwise, if an actual file or directory is requested, serve directly RewriteCond %{REQUEST_FILENAME} !-f RewriteCond %{REQUEST_FILENAME} !-d # Otherwise, pass everything through to the dispatcher RewriteRule ^(.*)$ /~mark/cgi-bin/dispatch.cgi/$1 [L,QSA] # These examples may also be helpful, but are unrelated to dispatching. SetEnv DEVMODE mark SetEnv PERL5LIB /home/mark/perllib:/home/mark/config ErrorDocument 404 /~mark/errdocs/404.html ErrorDocument 500 /~mark/errdocs/500.html =head1 SUBCLASSING While Dispatch tries to be flexible, it won't be able to do everything that people want. Hopefully we've made it flexible enough so that if it doesn't do I you can easily subclass it. =cut #=head2 PROTECTED METHODS # #The following methods are intended to be overridden by subclasses if #necessary. They are not part of the public API since end users will #never touch them. However, to ensure that your subclass of Dispatch #does not break with a new release, they are documented here and are #considered to be part of the API and will not be changed without very #good reasons. =head1 AUTHORS Mark Stosberg Heavily based on CGI::Application::Dispatch, written by Michael Peters and others =head1 COMMUNITY This module is a part of the larger L community. If you have questions or comments about this module then please join us on the cgiapp mailing list by sending a blank message to "cgiapp-subscribe@lists.erlbaum.net". There is also a community wiki located at L =head1 SOURCE CODE REPOSITORY A public source code repository for this project is hosted here: https://github.com/markstos/CGI--Application--Dispatch =head1 SECURITY Since C::A::Dispatch::PSGI will dynamically choose which modules to use as the content generators, it may give someone the ability to execute random modules on your system if those modules can be found in you path. Of course those modules would have to behave like L based modules, but that still opens up the door more than most want. This should only be a problem if you don't use a L. By using this option you are only allowing Dispatch to pick from a namespace of modules to run. =head1 Backwards Compatibility Versions 0.2 and earlier of this module injected the "as_psgi" method into CGI::Application::Dispatch, creating a syntax like this: ### in your dispatch.psgi: use Your::Application::Dispatch; use CGI::Application::Dispatch::PSGI; Your::Application::Dispatch->as_psgi; ### In Your::Application::Dispatch; use base 'CGI::Application::Dispatch::PSGI'; In the current design, the C<< as_pgsi >> method is directly in this module, so a couple of lines of code need to be changed: ### in your dispatch.psgi: use Your::Application::Dispatch; Your::Application::Dispatch->as_psgi; ### In Your::Application::Dispatch; use base 'CGI::Application::Dispatch::PSGI'; =head1 Differences with CGI::Application::Dispatch =over 4 =item dispatch() Use C<< as_psgi() >> instead. Note that the C key is not supported here. Use the L or another PSGI solution instead. =item dispatch_path() The dispatch_path() method is not supported. The alternative is to reference C<< $env->{PATH_INFO} >> which is available per the PSGI spec. =item handler() This provided an Apache-specific handler. Other PSGI components like L provide Apache handlers now instead. =item _http_method() This method has been eliminated. Check C<< $env->{REQUEST_METHOD} >> directly instead. =item _parse_path() The private _parse_path() method now accepts an additional argument, the PSGI C<< $env >> hash. =item _run_app() The private _run_app() method now accepts an additional argument, the PSGI C<< $env >> hash. =item _r() This method has been eliminated. It does not apply in PSGI. =back =head1 SEE ALSO L, L =head1 COPYRIGHT & LICENSE Copyright Michael Peters and Mark Stosberg 2008-2010, all rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut CGI-Application-Dispatch-3.12/lib/CGI/Application/Dispatch/Regexp.pm000444001750001750 703512024502644 24211 0ustar00markmark000000000000package CGI::Application::Dispatch::Regexp; use strict; use base 'CGI::Application::Dispatch'; our $VERSION = '3.04'; =pod =head1 NAME CGI::Application::Dispatch::Regexp - Dispatch requests to CGI::Application based objects using regular expressions =head1 SYNOPSIS use CGI::Application::Dispatch::Regexp; CGI::Application::Dispatch::Regexp->dispatch( prefix => 'MyApp', table => [ '' => { app => 'Welcome', rm => 'start', }, qr|/([^/]+)/?| => { names => ['app'], }, qr|/([^/]+)/([^/]+)/?| => { names => [qw(app rm)] }, qr|/([^/]+)/([^/]+)/page(\d+)\.html?| => { names => [qw(app rm page)] }, ], ); =head1 DESCRIPTION L uses its own syntax dispatch table. C allows one to use flexible and powerful Perl regular expressions to transform a path into argument list. =head1 DISPATCH TABLE The dispatch table should contain list of regular expressions with hashref of corresponding parameters. Hash element 'names' is a list of names of regular expression groups. The default table looks like this: table => [ qr|/([^/]+)/?| => { names => ['app'] }, qr|/([^/]+)/([^/]+)/?| => { names => [qw(app rm)] }, ], Here's an example of defining a custom 'page' parameter: qr|/([^/]+)/([^/]+)/page(\d+)\.html/?| => { names => [qw(app rm page)], }, =head1 COPYRIGHT & LICENSE Copyright Michael Peters and Mark Stosberg 2008, all rights reserved. =head1 SEE ALSO L, L =cut # protected method - designed to be used by sub classes, not by end users sub _parse_path { my ($self, $path, $table) = @_; # get the module name from the table return unless defined($path); unless(ref($table) eq 'ARRAY') { warn "Invalid or no dispatch table!\n"; return; } for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) { # translate the rule into a regular expression, but remember # where the named args are my $rule = $table->[$i]; warn "[Dispatch::Regexp] Trying to match '$path' against rule '$table->[$i]' using regex '$rule'\n" if $CGI::Application::Dispatch::DEBUG; # if we found a match, then run with it if(my @values = ($path =~ m|^$rule$|)) { warn "[Dispatch::Regexp] Matched!\n" if $CGI::Application::Dispatch::DEBUG; my %named_args = %{$table->[++$i]}; my $names = delete($named_args{names}); @named_args{@$names} = @values if(ref($names) eq 'ARRAY'); return \%named_args; } } return; } sub dispatch_args { my ($self, $args) = @_; return { default => ($args->{default} || ''), prefix => ($args->{prefix} || ''), args_to_new => ($args->{args_to_new} || {}), table => [ qr|/([^/]+)/?| => {names => ['app']}, qr|/([^/]+)/([^/]+)/?| => {names => [qw(app rm)]}, ], }; } 1;