apache-dispatch-devel Mailing List for Apache::Dispatch (Page 6)
Brought to you by:
geoffrey_young,
phred_moyer
Menu
▾
▴
apache-dispatch-devel — Apache::Dispatch development list
You can subscribe to this list here.
| 2006 |
Jan
|
Feb
|
Mar
(4) |
Apr
(33) |
May
(10) |
Jun
(22) |
Jul
(3) |
Aug
(15) |
Sep
(3) |
Oct
(3) |
Nov
|
Dec
|
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2007 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
(2) |
Aug
(5) |
Sep
|
Oct
|
Nov
|
Dec
(9) |
| 2008 |
Jan
(6) |
Feb
(2) |
Mar
|
Apr
|
May
|
Jun
(11) |
Jul
|
Aug
|
Sep
|
Oct
(2) |
Nov
|
Dec
|
| 2009 |
Jan
|
Feb
|
Mar
|
Apr
(12) |
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2010 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: <phr...@us...> - 2006-04-18 08:17:46
|
Revision: 19 Author: phred_moyer Date: 2006-04-18 01:17:42 -0700 (Tue, 18 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=19&view=rev Log Message: ----------- Add a few more tests for plain. So far we cover subclasses and index handlers. No doubt there are more to come but this is all for tonight. Modified Paths: -------------- trunk/t/lib/Apache2/Foo/Bar.pm trunk/t/lib/Apache2/Foo.pm trunk/t/plain.t Modified: trunk/t/lib/Apache2/Foo/Bar.pm =================================================================== --- trunk/t/lib/Apache2/Foo/Bar.pm 2006-04-18 02:57:29 UTC (rev 18) +++ trunk/t/lib/Apache2/Foo/Bar.pm 2006-04-18 08:17:42 UTC (rev 19) @@ -31,12 +31,12 @@ here is a sample httpd.conf entry - PerlModule Apache::Dispatch - PerlModule MP2Foo + PerlLoadModule Apache2::Dispatch + PerlModule Apache2::Foo::Bar <Location /Test> SetHandler perl-script - PerlHandler Apache::Dispatch + PerlHandler Apache2::Dispatch DispatchPrefix Foo DispatchExtras Pre Post Error </Location> Modified: trunk/t/lib/Apache2/Foo.pm =================================================================== --- trunk/t/lib/Apache2/Foo.pm 2006-04-18 02:57:29 UTC (rev 18) +++ trunk/t/lib/Apache2/Foo.pm 2006-04-18 08:17:42 UTC (rev 19) @@ -1,45 +1,50 @@ package Apache2::Foo; use Apache2::Const -compile => qw( OK SERVER_ERROR ); +use Apache2::RequestIO; use strict; sub dispatch_foo { - my $class = shift; - my $r = shift; - $r->send_http_header('text/plain'); + my ($class, $r) = @_; + + $r->content_type('text/plain'); $r->print("Foo->dispatch_foo()"); - print STDERR "Foo->dispatch_foo()\n"; + $r->log->debug("Foo->dispatch_foo()"); return Apache2::Const::OK; } sub dispatch_bar { - print STDERR "Foo->dispatch_bar()\n"; + my ($class, $r) = @_; + require Data::Dumper; + $r->log->debug("ARGV is " . Data::Dumper::Dumper(\@_)); + $r->log->debug( "Foo->dispatch_bar()"); return Apache2::Const::SERVER_ERROR; } sub pre_dispatch { - print STDERR "Foo->pre_dispatch()\n"; + my ($class, $r) = @_; + $r->log->debug("Foo->pre_dispatch()"); } sub post_dispatch { - print STDERR "Foo->post_dispatch()\n"; + my ($class, $r) = @_; + $r->log->debug("Foo->post_dispatch()"); } sub error_dispatch { - my $class = shift; - my $r = shift; - $r->send_http_header('text/plain'); + my ($class, $r) = @_; + + $r->send_http_header('text/plain'); $r->print("Yikes! Foo->dispatch_error()"); - print STDERR "Yikes! Foo->dispatch_error()\n"; return Apache2::Const::OK; } sub dispatch_index { - my $class = shift; - my $r = shift; - $r->send_http_header('text/plain'); + my ($class, $r) = @_; + + $r->content_type('text/plain'); $r->print("Foo->dispatch_index()"); - print STDERR "Foo->dispatch_index()\n"; + $r->log->debug( "Foo->dispatch_index()"); return Apache2::Const::OK; } @@ -50,12 +55,12 @@ here is a sample httpd.conf entry PerlModule Apache2::Dispatch - PerlModule Foo + PerlModule Apache2::Foo <Location /Test> SetHandler perl-script PerlHandler Apache2::Dispatch - DispatchPrefix Foo + DispatchPrefix Apache2::Foo DispatchExtras Pre Post Error </Location> Modified: trunk/t/plain.t =================================================================== --- trunk/t/plain.t 2006-04-18 02:57:29 UTC (rev 18) +++ trunk/t/plain.t 2006-04-18 08:17:42 UTC (rev 19) @@ -4,8 +4,21 @@ use Apache::Test; use Apache::TestRequest; -plan tests => 1, \&have_lwp; +plan tests => 4, \&have_lwp; -my $url = '/plain/Bar/baz'; +# Test Apache2::Foo->dispatch_index +my $url = '/plain/'; +ok GET_OK $url; +# Test Apache2::Foo->dispatch_foo +$url = '/plain/foo'; ok GET_OK $url; + +# Test Apache2::Foo::Bar->dispatch_index +$url = '/plain/Bar/'; +ok GET_OK $url; + +# Test Apache2::Foo::Bar->dispatch_foo +$url = '/plain/Bar/baz'; +ok GET_OK $url; + This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <phr...@us...> - 2006-04-18 02:57:34
|
Revision: 18 Author: phred_moyer Date: 2006-04-17 19:57:29 -0700 (Mon, 17 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=18&view=rev Log Message: ----------- time to turn up the font size on this laptop Modified Paths: -------------- trunk/t/conf/extra.last.conf.in Modified: trunk/t/conf/extra.last.conf.in =================================================================== --- trunk/t/conf/extra.last.conf.in 2006-04-18 02:39:38 UTC (rev 17) +++ trunk/t/conf/extra.last.conf.in 2006-04-18 02:57:29 UTC (rev 18) @@ -44,7 +44,7 @@ <IfDefine APACHE2> DispatchPrefix Apache2::Foo - PerlResponseHandler Apache::Dispatch + PerlResponseHandler Apache2::Dispatch </IfDefine> <IfDefine APACHE1> DispatchPrefix Apache::Foo This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <phr...@us...> - 2006-04-18 02:39:42
|
Revision: 17 Author: phred_moyer Date: 2006-04-17 19:39:38 -0700 (Mon, 17 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=17&view=rev Log Message: ----------- - I didn't think that it should be mod_perl2 here but perl has a different opinion. Modified Paths: -------------- trunk/Makefile.PL Modified: trunk/Makefile.PL =================================================================== --- trunk/Makefile.PL 2006-04-18 02:37:54 UTC (rev 16) +++ trunk/Makefile.PL 2006-04-18 02:39:38 UTC (rev 17) @@ -17,6 +17,7 @@ 'PREREQ_PM' => \%prereq, ); + # enable "make test" require Apache::TestMM; Apache::TestMM->import(qw(test clean)); @@ -30,7 +31,7 @@ $makefile_params{clean} = {FILES => "@scripts"}; if ($mp_wanted == 2) { # mod_perl2 specific makefile - $prereq{'mod_perl'} = 1.99023; # this covers the naming change + $prereq{'mod_perl2'} = 1.99023; # this covers the naming change $makefile_params{'NAME'} = 'Apache2::Dispatch'; require ModPerl::MM; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <phr...@us...> - 2006-04-18 02:38:00
|
Revision: 16 Author: phred_moyer Date: 2006-04-17 19:37:54 -0700 (Mon, 17 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=16&view=rev Log Message: ----------- Fixup test to use method matching method. Modified Paths: -------------- trunk/t/plain.t Modified: trunk/t/plain.t =================================================================== --- trunk/t/plain.t 2006-04-18 02:19:52 UTC (rev 15) +++ trunk/t/plain.t 2006-04-18 02:37:54 UTC (rev 16) @@ -6,6 +6,6 @@ plan tests => 1, \&have_lwp; -my $url = '/plain/Bar/good'; +my $url = '/plain/Bar/baz'; ok GET_OK $url; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <phr...@us...> - 2006-04-18 02:19:58
|
Revision: 15 Author: phred_moyer Date: 2006-04-17 19:19:52 -0700 (Mon, 17 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=15&view=rev Log Message: ----------- - first test is passing for Apache2 incarnation - refactor extra.last.conf.in a bit so we don't have to mess with the conf lib - move the test libs into Apache2 namespace - move the common functions (so far) into Apache::Dispatch::Util more stuff needs to be moved from Apache*::Dispatch into Apache::Dispatch::Util Modified Paths: -------------- trunk/t/conf/extra.last.conf.in Added Paths: ----------- trunk/lib/ trunk/lib/Apache/ trunk/lib/Apache/Dispatch/ trunk/lib/Apache/Dispatch/Util.pm trunk/lib/Apache/Dispatch.pm trunk/lib/Apache2/ trunk/lib/Apache2/Dispatch.pm trunk/t/lib/ trunk/t/lib/Apache2/ trunk/t/lib/Apache2/Foo/ trunk/t/lib/Apache2/Foo/Bar.pm trunk/t/lib/Apache2/Foo.pm Added: trunk/lib/Apache/Dispatch/Util.pm =================================================================== --- trunk/lib/Apache/Dispatch/Util.pm (rev 0) +++ trunk/lib/Apache/Dispatch/Util.pm 2006-04-18 02:19:52 UTC (rev 15) @@ -0,0 +1,157 @@ +package Apache::Dispatch::Util; + +use strict; +use warnings; + +=head1 NAME + + Apache::Dispatch::Util - methods for Apache::Dispatch and Apache2::Dispatch + +=head1 DESCRIPTION + +This package provides methods common to Apache::Dispatch and Apache2::Dispatch. + +=head1 VARIABLES + +=over 4 + +=item B<@_directives> + +Private lexical array which contains the directives for configuration. Used +by the directives() method. + +=back + +=cut + +my @directives = ( + + #------------------------------------------------------------------ + # DispatchPrefix defines the base class for a given <Location> + #------------------------------------------------------------------ + { + name => 'DispatchPrefix', + errmsg => 'a class to be used as the base class', + args_how => 'TAKE1', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchExtras defines the extra dispatch methods to enable + #------------------------------------------------------------------ + { + name => 'DispatchExtras', + errmsg => 'choose any of: Pre, Post, or Error', + args_how => 'ITERATE', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchStat enables module testing and subsequent reloading + #------------------------------------------------------------------ + { + name => 'DispatchStat', + errmsg => 'choose one of On, Off, or ISA', + args_how => 'TAKE1', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchAUTOLOAD defines AutoLoader behavior + #------------------------------------------------------------------ + { + name => 'DispatchAUTOLOAD', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchISA is a list of modules your module should inherit from + #------------------------------------------------------------------ + { + name => 'DispatchISA', + errmsg => 'a list of parent modules', + args_how => 'ITERATE', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchLocation allows you to redefine the <Location> + #------------------------------------------------------------------ + { + name => 'DispatchLocation', + errmsg => 'a location to replace the current <Location>', + args_how => 'TAKE1', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchRequire require()s the class + #------------------------------------------------------------------ + { + name => 'DispatchRequire', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchFilter makes the dispatched handler Apache::Filter aware + #------------------------------------------------------------------ + { + name => 'DispatchFilter', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchUppercase converts the first char of a class to uppercase + #------------------------------------------------------------------ + { + name => 'DispatchUpperCase', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, +); + +=head1 METHODS + +=over 4 + +=item C<directives> + +Provides the configuration directives in an array or array reference + + $directives = Apache::Dispatch::Util->directives; + @directives = Apache::Dispatch::Util->directives; + +=over 4 + +=item class: C<Apache::Dispatch::Util> ( class ) + +The calling class + +=item ret: C<$directives|@directives> ( ARRAY | ARRAY ref ) + +Returns the directives in an array or array reference depending on the context +in which it is called. + +=back + +=cut + +sub directives { + my $class = shift; + return wantarray ? @directives : \@directives; +} + +=pod + +=back + +=cut + +1; Added: trunk/lib/Apache/Dispatch.pm =================================================================== --- trunk/lib/Apache/Dispatch.pm (rev 0) +++ trunk/lib/Apache/Dispatch.pm 2006-04-18 02:19:52 UTC (rev 15) @@ -0,0 +1,1054 @@ +package Apache::Dispatch; + +# $Id: Dispatch.pm,v 1.34 2002/12/02 19:29:26 geoff Exp $ + +#--------------------------------------------------------------------- +# +# usage: PerlHandler Apache::Dispatch +# +#--------------------------------------------------------------------- + +use strict; +use warnings; + +my @directives = ( + + #------------------------------------------------------------------ + # DispatchPrefix defines the base class for a given <Location> + #------------------------------------------------------------------ + { + name => 'DispatchPrefix', + errmsg => 'a class to be used as the base class', + args_how => 'TAKE1', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchExtras defines the extra dispatch methods to enable + #------------------------------------------------------------------ + { + name => 'DispatchExtras', + errmsg => 'choose any of: Pre, Post, or Error', + args_how => 'ITERATE', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchStat enables module testing and subsequent reloading + #------------------------------------------------------------------ + { + name => 'DispatchStat', + errmsg => 'choose one of On, Off, or ISA', + args_how => 'TAKE1', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchAUTOLOAD defines AutoLoader behavior + #------------------------------------------------------------------ + { + name => 'DispatchAUTOLOAD', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchDebug defines debugging verbosity + #------------------------------------------------------------------ + { + name => 'DispatchDebug', + errmsg => 'numeric verbosity level', + args_how => 'TAKE1', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchISA is a list of modules your module should inherit from + #------------------------------------------------------------------ + { + name => 'DispatchISA', + errmsg => 'a list of parent modules', + args_how => 'ITERATE', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchLocation allows you to redefine the <Location> + #------------------------------------------------------------------ + { + name => 'DispatchLocation', + errmsg => 'a location to replace the current <Location>', + args_how => 'TAKE1', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchRequire require()s the class + #------------------------------------------------------------------ + { + name => 'DispatchRequire', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchFilter makes the dispatched handler Apache::Filter aware + #------------------------------------------------------------------ + { + name => 'DispatchFilter', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, + + #------------------------------------------------------------------ + # DispatchUppercase converts the first char of a class to uppercase + #------------------------------------------------------------------ + { + name => 'DispatchUpperCase', + errmsg => 'choose one of On or Off', + args_how => 'FLAG', + req_override => 'OR_ALL', + }, +); + +use mod_perl 1.2401; +use Apache::Constants qw(OK DECLINED SERVER_ERROR); +use Apache::Log; + +$Apache::Dispatch::PUREPERL = 'PUREPERL'; # set during perl Makefile.PL + +# create global hash to hold the modification times of the modules +my %stat = (); + +if ($Apache::Dispatch::PUREPERL == 0) { + require Apache::ModuleConfig; + require DynaLoader; + @Apache::Dispatch::ISA = qw(DynaLoader); + Apache::Dispatch->bootstrap($Apache::Dispatch::VERSION); +} + +sub directives { + return wantarray ? @directives : \@directives; +} + +# set debug level +# 0 - messages at info or debug log levels +# 1 - verbose output at info or debug log levels +# 2 - really verbose output at info or debug log levels +# this is rapidly becoming deprecated +$Apache::Dispatch::DEBUG = 0; + +sub handler { + + #--------------------------------------------------------------------- + # initialize request object and variables + #--------------------------------------------------------------------- + + my $r = shift; + + my $dcfg; + if ($Apache::Dispatch::PUREPERL == 0) { + $dcfg = Apache::ModuleConfig->get($r, __PACKAGE__); + } + else { + $dcfg = get_pureperl_config($r); + } + + my $filter = $dcfg->{_filter} + || $r->dir_config('Filter') + || 0; + + my $debug = + defined $dcfg->{_debug} + ? $dcfg->{_debug} + : $Apache::Dispatch::DEBUG; + + my $autoload = $dcfg->{_autoload}; + + my $stat = $dcfg->{_stat}; + + my $prefix = $dcfg->{_prefix}; + + my $uppercase = $dcfg->{_uppercase}; + + my $new_location = $dcfg->{_newloc}; + + my $require = $dcfg->{_require}; + + my @parents = $dcfg->{_isa} ? @{$dcfg->{_isa}} : (); + + my @extras = $dcfg->{_extras} ? @{$dcfg->{_extras}} : (); + + my $log = $r->server->log; + + my $uri = $r->uri; + + my ($prehandler, $posthandler, $errorhandler, $rc); + + #--------------------------------------------------------------------- + # do some preliminary stuff... + #--------------------------------------------------------------------- + + $log->info("Using Apache::Dispatch") if $debug > 0; + + # redefine $r as necessary for Apache::Filter 1.013 and above + if ($filter) { + $log->info("\tregistering handler with Apache::Filter") + if $debug > 1; + + # in case we used DispatchFilter directive instead, make sure + # that other filters in the chain recognize us... + $r->dir_config->set(Filter => 'On'); + + $r = $r->filter_register; + $log = $r->server->log; + } + + $log->info("\tchecking $uri for possible dispatch...") + if $debug; + + # if the uri contains any characters we don't like, bounce... + # is this necessary? + if ($uri =~ m![^\w/-]!) { + $log->info("\t$uri has bogus characters...") + if $debug; + $log->info("Exiting Apache::Dispatch"); + return DECLINED; + } + + if ($debug > 1) { + $log->info( + "\tapplying the following dispatch rules:", + "\n\t\tDispatchPrefix: ", + $prefix, + "\n\t\tDispatchUpperCase: ", + $uppercase, + "\n\t\tDispatchStat: ", + $stat, + "\n\t\tDispatchFilter: ", + $filter, + "\n\t\tDispatchDebug: ", + $debug, + "\n\t\tDispatchLocation: ", + $new_location ? $new_location : "Unaltered", + "\n\t\tDispatchAUTOLOAD: ", + $autoload, + "\n\t\tDispatchRequire: ", + $require, + "\n\t\tDispatchExtras: ", + (@extras ? (join ' ', @extras) : "None"), + "\n\t\tDispatchISA: ", + (@parents ? (join ' ', @parents) : "None"), + ); + } + + #--------------------------------------------------------------------- + # create the new object + #--------------------------------------------------------------------- + + my ($class, $method) = + _translate_uri($r, $prefix, $new_location, $log, $debug); + + unless ($class && $method) { + $log->info("\tclass and method could not be discovered") + if $debug; + $log->info("Exiting Apache::Dispatch") if $debug > 0; + return DECLINED; + } + + if ($uppercase) { + $class =~ s/::([a-z])/::\U$1/g; + } + + my $object = {}; + + bless $object, $class; + + #--------------------------------------------------------------------- + # set parent classes for DispatchISA + #--------------------------------------------------------------------- + + if (@parents) { + $rc = _set_ISA($class, $log, $debug, @parents); + + unless ($rc) { + $log->error("\tDispatchISA did not return successfully!"); + $log->info("Exiting Apache::Dispatch"); + return DECLINED; + } + } + + #--------------------------------------------------------------------- + # require the module if DispatchRequire On + #--------------------------------------------------------------------- + + if ($require) { + $log->info("\tattempting to require $class...") + if $debug > 1; + + eval "require $class"; + + if ($@) { + $log->warn("\tcould not require $class: $@"); + $log->info("Exiting Apache::Dispatch"); + return DECLINED; + } + else { + $log->info("\t$class required successfully") + if $debug > 1; + } + } + + #--------------------------------------------------------------------- + # reload the module if DispatchStat On or ISA + #--------------------------------------------------------------------- + + if ($stat eq "ON") { + $rc = _stat($class, $log, $debug); + + unless ($rc) { + $log->error("\tDispatchStat did not return successfully!"); + $log->info("Exiting Apache::Dispatch"); + return DECLINED; + } + } + elsif ($stat eq "ISA") { + $rc = _recurse_stat($class, $log, $debug); + + unless ($rc) { + $log->error("\tDispatchStat did not return successfully!"); + $log->info("Exiting Apache::Dispatch"); + return DECLINED; + } + } + + #--------------------------------------------------------------------- + # see if the handler is a valid method + # if not, decline the request + #--------------------------------------------------------------------- + + my $handler = _check_dispatch($object, $method, $autoload, $log, $debug); + + if ($handler) { + $log->info("\t$uri was translated into $class->$method") + if $debug; + } + else { + $log->info("\t$uri did not result in a valid method") + if $debug; + $log->info("Exiting Apache::Dispatch"); + return DECLINED; + } + + #--------------------------------------------------------------------- + # since the uri is dispatchable, check each of the extras + #--------------------------------------------------------------------- + foreach my $extra (@extras) { + if ($extra eq "PRE") { + $prehandler = + _check_dispatch($object, "pre_dispatch", $autoload, $log, $debug); + } + elsif ($extra eq "POST") { + $posthandler = + _check_dispatch($object, "post_dispatch", $autoload, $log, + $debug); + } + elsif ($extra eq "ERROR") { + $errorhandler = + _check_dispatch($object, "error_dispatch", $autoload, $log, + $debug); + } + } + + #--------------------------------------------------------------------- + # run each of the enabled methods, ignoring pre and post errors + #--------------------------------------------------------------------- + + eval { $object->$prehandler($r) } if $prehandler; + + eval { $rc = $object->$handler($r) }; + + if ($errorhandler && ($@ || $rc != OK)) { + + # if the error handler dies we want to catch it, so don't eval + $rc = $object->$errorhandler($r, $@, $rc); + } + elsif ($@) { + $log->error("$class->$method died: $@"); + $rc = SERVER_ERROR; + } + + eval { $object->$posthandler($r) } if $posthandler; + + #--------------------------------------------------------------------- + # wrap up... + #--------------------------------------------------------------------- + + $log->info("\tApache::Dispatch is returning $rc") + if $debug; + + $log->info("Exiting Apache::Dispatch"); + + return $rc; +} + +#********************************************************************* +# the below methods are not part of the external API +#********************************************************************* + +sub _translate_uri { + + #--------------------------------------------------------------------- + # take the uri and return a class and method + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($r, $prefix, $newloc, $log, $debug) = @_; + + my $uri = $r->uri; + + my $location; + + # change all the / to :: + (my $class_and_method = $r->uri) =~ s!/!::!g; + + if ($newloc) { + $log->info("\tmodifying location from ", $r->location, " to $newloc") + if $debug > 1; + ($location = $newloc) =~ s!/!::!g; + } + else { + ($location = $r->location) =~ s!/!::!g; + } + + # strip off the leading and trailing :: if any + $class_and_method =~ s/^::|::$//g; + $location =~ s/^::|::$//g; + + # substitute the prefix for the location + # <Location /> is a special case that we can deal with + # (but not advertise :) + my $times; + + if ($location) { + $times = $class_and_method =~ s/^\Q$location/$prefix/e; + } + else { + + # <Location /> + $prefix .= "::"; + $times = $class_and_method =~ s/^/$prefix/e; + } + + unless ($times) { + $log->info("\tLocation substitution failed - uri not translated") + if $debug > 1; + + return (undef, undef); + } + + my ($class, $method); + + if ($prefix eq $class_and_method) { + $method = "dispatch_index"; + $class = $prefix; + } + else { + ($class, $method) = $class_and_method =~ m/(.*)::(.*)/; + $method = "dispatch_$method"; + } + + return ($class, $method); +} + +sub _check_dispatch { + + #--------------------------------------------------------------------- + # see if class->method() is a valid call + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($object, $method, $autoload, $log, $debug) = @_; + + my $class = ref($object); + + my $coderef; + + $log->info("\tchecking the validity of $class->$method...") + if $debug > 1; + + if ($autoload) { + $coderef = $object->can($method) || $object->can("AUTOLOAD"); + } + else { + $coderef = $object->can($method); + } + + if ($coderef && $debug > 1) { + $log->info("\t$class->$method is a valid method call"); + } + elsif ($debug > 1) { + $log->info("\t$class->$method is not a valid method call"); + } + + return $coderef; +} + +sub _stat { + + #--------------------------------------------------------------------- + # stat and reload the module if it has changed... + # this method is for internal use only + #--------------------------------------------------------------------- + # Use Apache::Reload here?? + my ($class, $log, $debug) = @_; + + (my $module = $class) =~ s!::!/!g; + + $module .= ".pm"; + + $stat{$module} = $^T unless $stat{$module}; + + if ($INC{$module}) { + $log->info("\tchecking $module for reload in pid $$...") + if $debug > 1; + + my $mtime = (stat $INC{$module})[9]; + + unless (defined $mtime && $mtime) { + $log->warn("Apache::Dispatch cannot find $module!"); + return 1; + } + + if ($mtime > $stat{$module}) { + + # turn off warnings for this bit... + local $^W; + + delete $INC{$module}; + eval { require $module }; + + if ($@) { + $log->error("Apache::Dispatch: $module failed reload! $@"); + return undef; + } + elsif ($debug) { + $log->info("\t$module reloaded"); + } + $stat{$module} = $mtime; + } + else { + $log->info("\t$module not modified") + if $debug > 1; + } + } + else { + $log->warn("Apache::Dispatch: $module not in \%INC!"); + } + + return 1; +} + +sub _recurse_stat { + + #--------------------------------------------------------------------- + # recurse through all the parent classes of the current class + # and call _stat on each + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($class, $log) = @_; + + my $rc = _stat($class, $log); + + return undef unless $rc; + + # turn off strict here so we can get at the class @ISA + no strict 'refs'; + + foreach my $package (@{"${class}::ISA"}) { + $rc = _recurse_stat($package, $log); + last unless $rc; + } + + return $rc; +} + +sub _set_ISA { + + #--------------------------------------------------------------------- + # set the ISA array for the class + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($class, $log, $debug, @parents) = @_; + + # turn off strict here so we can get at the class @ISA + no strict 'refs'; + + if ($debug > 1) { + $log->info("\t\@ISA for $class currently contains ", + (join ", ", @{"${class}::ISA"})); + $log->info("\tabout to merge ", (join ", ", @parents)); + } + + # only add classes to @ISA if they are not there already + my %seen; + + @{"${class}::ISA"} = grep !$seen{$_}++, (@{"${class}::ISA"}, @parents); + + return 1; +} + +#--------------------------------------------------------------------- +# Pure Perl configuration methods +#--------------------------------------------------------------------- + +sub get_pureperl_config { + my $r = shift; + my $cfg = {}; + no strict 'refs'; + foreach my $key ( + qw(DispatchPrefix DispatchExtras DispatchStat DispatchAUTOLOAD DispatchDebug DispatchISA DispatchLocation DispatchRequire DispatchFilter DispatchUpperCase) + ) + { + my $arg = $r->dir_config($key); + next unless $arg; + &$key($cfg, undef, $arg); + } + return $cfg; +} + +#--------------------------------------------------------------------- +# Apache configuration methods +#--------------------------------------------------------------------- + +sub _new { + return bless {}, shift; +} + +sub DIR_CREATE { + my $class = shift; + my $self = $class->_new; + + $self->{_stat} = "Off"; # no reloading by default + $self->{_autoload} = 0; # no autloading by default + $self->{_require} = 0; # no require()ing by default + + # warn "inside DIR_CREATE"; + return $self; +} + +sub DIR_MERGE { + my ($parent, $current) = @_; + my %new = (%$parent, %$current); + + # warn "inside DIR_MERGE"; + return bless \%new, ref($parent); +} + +sub DispatchLocation ($$$) { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_newloc} = $arg; +} + +sub DispatchPrefix ($$$) { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_prefix} = $arg; +} + +sub DispatchExtras ($$@) { + my ($cfg, $parms, $arg) = @_; + + if ($arg =~ m/^(Pre|Post|Error)$/i) { + push @{$cfg->{_extras}}, uc($arg) + unless grep /$arg/i, @{$cfg->{_extras}}; + } + else { + die "Invalid DispatchExtra $arg!"; + } +} + +sub DispatchISA ($$@) { + my ($cfg, $parms, $arg) = @_; + + push @{$cfg->{_isa}}, $arg + unless grep /$arg/, @{$cfg->{_isa}}; +} + +sub DispatchStat ($$$) { + my ($cfg, $parms, $arg) = @_; + + if ($arg =~ m/^(On|Off|ISA)$/i) { + $cfg->{_stat} = uc($arg); + } + else { + die "Invalid DispatchStat $arg!"; + } +} + +sub DispatchRequire ($$$) { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_require} = $arg; +} + +sub DispatchFilter ($$$) { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_filter} = $arg; +} + +sub DispatchAUTOLOAD ($$$) { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_autoload} = $arg; +} + +sub DispatchDebug ($$$) { + my ($cfg, $parms, $arg) = @_; + + if ($arg =~ m/[0-9]/) { + $cfg->{_debug} = $arg; + } + else { + die "Invalid DispatchDebug $arg!"; + } +} + +sub DispatchUpperCase ($$$) { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_uppercase} = $arg; +} + +1; + +__END__ + +=head1 NAME + +Apache::Dispatch - call PerlHandlers with the ease of Registry scripts + +=head1 SYNOPSIS + +httpd.conf: + + PerlModule Apache::Dispatch + PerlModule Bar + + DispatchExtras Pre Post Error + DispatchStat On + DispatchISA "My::Utils" + DispatchAUTOLOAD Off + + <Location /Foo> + SetHandler perl-script + PerlHandler Apache::Dispatch + + DispatchPrefix Bar + DispatchFilter Off + </Location> + +=head1 DESCRIPTION + +Apache::Dispatch translates $r->uri into a class and method and runs +it as a PerlHandler. Basically, this allows you to call PerlHandlers +as you would Regsitry scripts without having to load your httpd.conf +with a slurry of <Location> tags. + +=head1 EXAMPLE + + in httpd.conf + + PerlModule Apache::Dispatch + PerlModule Bar + + <Location /Foo> + SetHandler perl-script + PerlHandler Apache::Dispatch + + DispatchPrefix Bar + </Location> + + in browser: + http://localhost/Foo/baz + + the results are the same as if your httpd.conf looked like: + <Location /Foo> + SetHandler perl-script + PerlHandler Bar->dispatch_baz + </Location> + +but with the additional security of protecting the class name from +the browser and keeping the method name from being called directly. +Because any class under the Bar:: hierarchy can be called, one +<Location> directive is able to handle all the methods of Bar, +Bar::Baz, etc... + +=head1 CONFIGURATION DIRECTIVES + + DispatchPrefix + The base class to be substituted for the $r->location part of the + uri. + + DispatchLocation + Using Apache::Dispatch from a <Directory> directive, either + directly or from a .htaccess file, will _require_ the use of + DispatchLocation, which defines the location from which + Apache::Dispatch will start class->method() translation. + For example: + + httpd.conf + DocumentRoot /usr/local/apache/htdocs + <Directory /usr/local/apache/htdocs/> + ... + <Directory> + + .htaccess (in /usr/local/apache/htdocs/Foo) + SetHandler perl-script + PerlHandler Apache::Dispatch + DispatchPrefix Baz + DispatchLocation /Foo + + This allows a request to /Foo/Bar/biff to properly map to + Baz::Bar->biff(). + + While intended specifically for <Directory> configurations, one + could use DispatchLocation to further obscure uri translations + within <Location> sections as well by changing the part of + the uri that is substitued with your module. + + DispatchExtras + An optional list of extra processing to enable per-request. If + the main handler is not a valid method call, the request is + declined prior to the execution of any of the extra methods. + + Pre - eval()s Foo->pre_dispatch($r) prior to dispatching the + uri. The $@ of the eval is not checked in any way. + + Post - eval()s Foo->post_dispatch($r) after dispatching the + uri. The $@ of the eval is not checked in any way. + + Error - If the main handler returns other than OK then + Foo->error_dispatch($r, $@) is called and return status + of it is returned instead. Unlike the pre and post + processing routines above, error_dispatch is not wrapped + in an eval, so if it dies, the Apache::Dispatch dies, + and Apache will process the error using ErrorDocument, + custom_response(), etc. + With error_dispatch() disabled, the return status of the + the main handler is returned to the client. + + DispatchRequire + An optional directive that enables require()ing of the module that + is the result of the uri to class->method translation. This allows + your configuration to be a bit more dynamic, but also decreases + security somewhat. And don't forget that you really should be + pre-loading frequently used modules in the parent process to reduce + overhead - DispatchRequire is a directive of conveinence. + + On - require() the module + + Off - Do not require() the module (Default) + + DispatchStat + An optional directive that enables reloading of the module that is + the result of the uri to class->method translation, similar to + Apache::Registry, Apache::Reload, or Apache::StatINC. + + On - Test the called package for modification and reload on + change + + Off - Do not test or reload the package (Default) + + ISA - Test the called package, and all other packages in the + called package's @ISA, and reload on change + + DispatchAUTOLOAD + An optional directive that enables unknown methods to use + AutoLoader. It may be applied on a per-server or per-location + basis and defaults to Off. Please see the special section on + AUTOLOAD below. + + On - Allow for methods to be defined in AUTOLOAD method + + Off - Turn off search for AUTOLOAD method (Default) + + DispatchISA + An optional list of parent classes you want your dispatched class + to inherit from. + + DispatchFilter + If you have Apache::Filter 1.013 or above installed, you can take + advantage of other Apache::Filter aware modules. Please see the + section on FILTERING below. In keeping with Apache::Filter + standards, PerlSetVar Filter has the same effect as DispatchFilter + but with lower precedence. + + On - make the output of your module Apache::Filter aware + + Off - do not use Apache::Filter (Default) + + DispatchDebug + Apache::Dispatch uses $r->server->log->info() for debugging. + Verbose debugging is enabled by setting DispatchDebug to 1. + Very verbose debugging is enabled at 2. $Apache::Dispatch::DEBUG + remains for backward compatibility, but is soon to be deprecated. + To turn off all debug information set your Apache LogLevel + directive above info level. + +=head1 SPECIAL CODING GUIDELINES + +Migrating to Apache::Dispatch is relatively painless - it requires +only a few minor code changes. The good news is that once you adapt +code to work with Dispatch, it can be used as a conventional mod_perl +method handler, requiring only a few considerations. Below are a few +things that require attention. + +In the interests of security, all handler methods must be prefixed +with 'dispatch_', which is added to the uri behind the scenes. Unlike +ordinary mod_perl handlers, for Apache::Dispatch there is no default +method (with a tiny exception - see NOTES below). + +Apache::Dispatch uses object oriented calls behind the scenes. This +means that you either need to account for your handler to be called +as a method handler, such as + + sub dispatch_bar { + my $self = shift; # your class + my $r = shift; + } + +or get the Apache request object directly via + + sub dispatch_bar { + my $r = Apache->request; + } + +If you want to use the handler unmodified outside of Apache::Dispatch, +you must do three things: + + prototype your handler: + + sub dispatch_baz ($$) { + my $self = shift; + my $r = shift; + } + + change your httpd.conf entry: + + <Location /Foo> + SetHandler perl-script + PerlHandler Bar->dispatch_baz + </Location> + + pre-load your module: + PerlModule Bar + or + PerlRequire startup.pl + # where startup.pl contains + # use Bar; + +That's it - now the handler can be swapped in and out of Dispatch +without further modification. See the Eagle book on method handlers +for more details. + +=head1 FILTERING + +Apache::Dispatch provides for output filtering using Apache::Filter +1.013 and above. + + <Location /Foo> + SetHandler perl-script + PerlHandler Apache::Dispatch Apache::Compress + + DispatchPrefix Bar + DispatchFilter On + </Location> + +Your handler need do nothing special to make its output the start of +the chain - Apache::Dispatch registers itself with Apache::Filter and +hides the task from your handler. Thus, any dispatched handler is +automatically Apache::Filter ready without the need for additional +code. + +The only caveat is that you must use the request object that is passed +to the handler and not get it directly using Apache->request. + +=head1 AUTOLOAD + +Support for AUTOLOAD has been made optional, but requires special +care. Please take the time to read the camel book on using AUTOLOAD +with can() and subroutine declarations (3rd ed pp326-329). + +Basically, you declare the methods you want AUTOLOAD to capture by +name at the top of your script. This is necessary because can() +will return true if your class (or any parent class) contains an +AUTOLOAD method, but $AUTOLOAD will only be populated for declared +method calls. Hence, without a declaration you won't be able to +get at the name of the method you want to AUTOLOAD. + +DispatchISA introduced some convenience, but some headaches as well - +if you inherit from a class that uses AutoLoader then ALL method calls +are true. And as just explained, AUTOLOAD() will not know what the +called method was. This may represent a problem if you aren't aware +that, say, CGI.pm uses AutoLoader and spend a few hours trying to +figure out why all of a sudden every URL under Dispatch is bombing. +You may want to check out NEXT.pm (available from CPAN) for use in +your AUTOLOAD routines to help circumvent this partucular feature. + +If you decide to use DispatchISA it is HIGHLY SUGGESTED that you do so +with DispatchAUTOLOAD Off (which is the default behavior). + +=head1 NOTES + +If you define a dispatch_index() method calls to /Foo will default to +it. Unfortunately, this implicit translation only happens at the +highest level - calls to /Foo/Bar will translate to Foo->Bar() (that +is, unless Foo::Bar is your DispatchPrefix, in which case it will +work but /Foo/Bar/Baz will not, etc). Explicit calls to /Foo/index +follow the normal dispatch rules. + +If the uri can be dispatched but contains anything other than +[a-zA-Z0-9_/-] Apache::Dispatch declines to handle the request. + +Like everything in perl, the package names are case sensitive. + +Warnings have been left on, so if you set an invalid class with +DispatchISA you will see a message like: + Can't locate package Foo::Bar for @Bar::Baz::ISA at + .../Apache/Dispatch.pm line 277. + +This is alpha software, and as such has not been tested on multiple +platforms or environments for security, stability or other concerns. +It requires PERL_DIRECTIVE_HANDLERS=1, PERL_LOG_API=1, PERL_HANDLER=1, +and maybe other hooks to function properly. + +=head1 FEATURES/BUGS + +If a module fails reload under DispatchStat, Apache::Dispatch declines +the request. This might change to SERVER_ERROR in the future... + +=head1 SEE ALSO + +perl(1), mod_perl(1), Apache(3), Apache::Filter(3), Apache::Reload(3), +Apache::StatINC(3) + +=head1 AUTHOR + +Geoffrey Young <ge...@cp...> + +=head1 COPYRIGHT + +Copyright 2001 Geoffrey Young - all rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Added: trunk/lib/Apache2/Dispatch.pm =================================================================== --- trunk/lib/Apache2/Dispatch.pm (rev 0) +++ trunk/lib/Apache2/Dispatch.pm 2006-04-18 02:19:52 UTC (rev 15) @@ -0,0 +1,902 @@ +package Apache2::Dispatch; + +#--------------------------------------------------------------------- +# +# usage: PerlHandler Apache::Dispatch +# +#--------------------------------------------------------------------- + +use strict; +use warnings; + +$Apache2::Dispatch::VERSION = '0.15'; + +use mod_perl2 1.99023; +use Apache2::Const -compile => qw(OK DECLINED SERVER_ERROR); +use Apache2::Log (); +use Apache2::Module (); +use Apache2::RequestRec (); +use Apache2::RequestUtil (); +use Apache::Dispatch::Util (); + +# Read server config and use this if appropriate +use Data::Dumper; + +# Initialize the directives +my $directives = Apache::Dispatch::Util->directives(); +Apache2::Module::add(__PACKAGE__, $directives); + +# create global hash to hold the modification times of the modules +my %stat = (); + +$Apache::Dispatch::PUREPERL ||= 0; + +sub handler { + + #--------------------------------------------------------------------- + # initialize request object and variables + #--------------------------------------------------------------------- + my $r = shift; + + # Is there an advantage to keeping the pureperl option? + my $dcfg; + if ($Apache::Dispatch::PUREPERL == 0) { + $dcfg = + Apache2::Module::get_config(__PACKAGE__, $r->server, + $r->per_dir_config); + } + else { + $dcfg = get_pureperl_config($r); + } + + my $filter = $dcfg->{_filter} + || $r->dir_config('Filter') + || 0; + + my $autoload = $dcfg->{_autoload}; + + my $stat = $dcfg->{_stat}; + + my $prefix = $dcfg->{_prefix}; + + my $uppercase = $dcfg->{_uppercase} || 0; + + my $new_location = $dcfg->{_newloc}; + + my $require = $dcfg->{_require}; + + my @parents = $dcfg->{_isa} ? @{$dcfg->{_isa}} : (); + + my @extras = $dcfg->{_extras} ? @{$dcfg->{_extras}} : (); + + my $log = $r->server->log; + + my $uri = $r->uri; + + my ($prehandler, $posthandler, $errorhandler, $rc); + + #--------------------------------------------------------------------- + # do some preliminary stuff... + #--------------------------------------------------------------------- + + $log->debug("Using Apache2::Dispatch"); + + # redefine $r as necessary for Apache::Filter 1.013 and above + if ($filter) { + $log->debug("\tregistering handler with Apache::Filter"); + + require Apache2::Filter; + + # in case we used DispatchFilter directive instead, make sure + # that other filters in the chain recognize us... + $r->dir_config->set(Filter => 'On'); + + $r = $r->filter_register; + $log = $r->server->log; + } + + $log->debug("\tchecking $uri for possible dispatch..."); + + # if the uri contains any characters we don't like, bounce... + if ($uri =~ m![^\w/-]!) { + $log->debug("\t$uri has bogus characters..."); + $log->info("Exiting Apache::Dispatch"); + return Apache2::Const::DECLINED; + } + + $log->debug( + "\tapplying the following dispatch rules:", + "\n\t\tDispatchPrefix: ", + $prefix, + "\n\t\tDispatchUpperCase: ", + $uppercase, + "\n\t\tDispatchStat: ", + $stat, + "\n\t\tDispatchFilter: ", + $filter, + "\n\t\tDispatchLocation: ", + $new_location ? $new_location : "Unaltered", + "\n\t\tDispatchAUTOLOAD: ", + $autoload, + "\n\t\tDispatchRequire: ", + $require, + "\n\t\tDispatchExtras: ", + (@extras ? (join ' ', @extras) : "None"), + "\n\t\tDispatchISA: ", + (@parents ? (join ' ', @parents) : "None"), + ); + + #--------------------------------------------------------------------- + # create the new object + #--------------------------------------------------------------------- + + my ($class, $method) = _translate_uri($r, $prefix, $new_location, $log); + + unless ($class && $method) { + $log->debug("\tclass and method could not be discovered"); + $log->debug("Exiting Apache::Dispatch"); + return Apache2::Const::DECLINED; + } + + if ($uppercase) { + $class =~ s/::([a-z])/::\U$1/g; + } + + my $object = {}; + + bless $object, $class; + + #--------------------------------------------------------------------- + # set parent classes for DispatchISA + #--------------------------------------------------------------------- + + if (@parents) { + $rc = _set_ISA($class, $log, @parents); + + unless ($rc) { + $log->error("\tDispatchISA did not return successfully!"); + $log->info("Exiting Apache::Dispatch"); + return Apache2::Const::DECLINED; + } + } + + #--------------------------------------------------------------------- + # require the module if DispatchRequire On + #--------------------------------------------------------------------- + + if ($require) { + $log->info("\tattempting to require $class..."); + + eval "require $class"; + + if ($@) { + $log->warn("\tcould not require $class: $@"); + $log->info("Exiting Apache::Dispatch"); + return Apache2::Const::DECLINED; + } + else { + $log->info("\t$class required successfully"); + } + } + + #--------------------------------------------------------------------- + # reload the module if DispatchStat On or ISA + #--------------------------------------------------------------------- + + if ($stat eq "ON") { + $rc = _stat($class, $log); + + unless ($rc) { + $log->error("\tDispatchStat did not return successfully!"); + $log->info("Exiting Apache::Dispatch"); + return Apache2::Const::DECLINED; + } + } + elsif ($stat eq "ISA") { + $rc = _recurse_stat($class, $log); + + unless ($rc) { + $log->error("\tDispatchStat did not return successfully!"); + $log->info("Exiting Apache::Dispatch"); + return Apache2::Const::DECLINED; + } + } + + #--------------------------------------------------------------------- + # see if the handler is a valid method + # if not, decline the request + #--------------------------------------------------------------------- + + my $handler = _check_dispatch($object, $method, $autoload, $log); + + if ($handler) { + $log->info("\t$uri was translated into $class->$method"); + } + else { + $log->info("\t$uri did not result in a valid method"); + $log->info("Exiting Apache::Dispatch"); + return Apache2::Const::DECLINED; + } + + #--------------------------------------------------------------------- + # since the uri is dispatchable, check each of the extras + #--------------------------------------------------------------------- + foreach my $extra (@extras) { + if ($extra eq "PRE") { + $prehandler = + _check_dispatch($object, "pre_dispatch", $autoload, $log); + } + elsif ($extra eq "POST") { + $posthandler = + _check_dispatch($object, "post_dispatch", $autoload, $log); + } + elsif ($extra eq "ERROR") { + $errorhandler = + _check_dispatch($object, "error_dispatch", $autoload, $log); + } + } + + #--------------------------------------------------------------------- + # run each of the enabled methods, ignoring pre and post errors + #--------------------------------------------------------------------- + + eval { $object->$prehandler($r) } if $prehandler; + + eval { $rc = $object->$handler($r) }; + + if ($errorhandler && ($@ || $rc != Apache2::Const::OK)) { + + # if the error handler dies we want to catch it, so don't eval + $rc = $object->$errorhandler($r, $@, $rc); + } + elsif ($@) { + $log->error("$class->$method died: $@"); + $rc = Apache2::Const::SERVER_ERROR; + } + + eval { $object->$posthandler($r) } if $posthandler; + + #--------------------------------------------------------------------- + # wrap up... + #--------------------------------------------------------------------- + + $log->info("\tApache::Dispatch is returning $rc"); + + $log->info("Exiting Apache::Dispatch"); + + return $rc; +} + +#********************************************************************* +# the below methods are not part of the external API +#********************************************************************* + +sub _translate_uri { + + #--------------------------------------------------------------------- + # take the uri and return a class and method + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($r, $prefix, $newloc, $log) = @_; + + my $uri = $r->uri; + + my $location; + + # change all the / to :: + (my $class_and_method = $r->uri) =~ s!/!::!g; + + if ($newloc) { + $log->info("\tmodifying location from ", $r->location, " to $newloc"); + ($location = $newloc) =~ s!/!::!g; + } + else { + ($location = $r->location) =~ s!/!::!g; + } + + # strip off the leading and trailing :: if any + $class_and_method =~ s/^::|::$//g; + $location =~ s/^::|::$//g; + + # substitute the prefix for the location + # <Location /> is a special case that we can deal with + # (but not advertise :) + my $times; + + if ($location) { + $r->log->debug( +"Location: $location, Prefix $prefix, Class_and_method $class_and_method"); + $times = $class_and_method =~ s/^\Q$location/$prefix/e; + } + else { + + # <Location /> + $prefix .= "::"; + $times = $class_and_method =~ s/^/$prefix/e; + } + + unless ($times) { + $log->info("\tLocation substitution failed - uri not translated"); + + return (undef, undef); + } + + my ($class, $method); + + if ($prefix eq $class_and_method) { + $method = "dispatch_index"; + $class = $prefix; + } + else { + ($class, $method) = $class_and_method =~ m/(.*)::(.*)/; + $method = "dispatch_$method"; + } + + return ($class, $method); +} + +sub _check_dispatch { + + #--------------------------------------------------------------------- + # see if class->method() is a valid call + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($object, $method, $autoload, $log) = @_; + + my $class = ref($object); + + my $coderef; + + $log->info("\tchecking the validity of $class->$method..."); + + if ($autoload) { + $coderef = $object->can($method) || $object->can("AUTOLOAD"); + } + else { + $coderef = $object->can($method); + } + + if ($coderef) { + $log->debug("\t$class->$method is a valid method call"); + } + elsif (!$coderef) { + $log->warn("\t$class->$method is not a valid method call"); + } + + return $coderef; +} + +sub _stat { + + #--------------------------------------------------------------------- + # stat and reload the module if it has changed... + # this method is for internal use only + #--------------------------------------------------------------------- + # Use Apache::Reload here?? + my ($class, $log) = @_; + + (my $module = $class) =~ s!::!/!g; + + $module .= ".pm"; + + $stat{$module} = $^T unless $stat{$module}; + + if ($INC{$module}) { + $log->info("\tchecking $module for reload in pid $$..."); + + my $mtime = (stat $INC{$module})[9]; + + unless (defined $mtime && $mtime) { + $log->warn("Apache::Dispatch cannot find $module!"); + return 1; + } + + if ($mtime > $stat{$module}) { + + # turn off warnings for this bit... + local $^W; + + delete $INC{$module}; + eval { require $module }; + + if ($@) { + $log->error("Apache::Dispatch: $module failed reload! $@"); + return; + } + elsif (!$@) { + $log->debug("\t$module reloaded"); + } + $stat{$module} = $mtime; + } + else { + $log->info("\t$module not modified"); + } + } + else { + $log->warn("Apache::Dispatch: $module not in \%INC!"); + } + + return 1; +} + +sub _recurse_stat { + + #--------------------------------------------------------------------- + # recurse through all the parent classes of the current class + # and call _stat on each + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($class, $log) = @_; + + my $rc = _stat($class, $log); + + return unless $rc; + + # turn off strict here so we can get at the class @ISA + no strict 'refs'; + + foreach my $package (@{"${class}::ISA"}) { + $rc = _recurse_stat($package, $log); + last unless $rc; + } + + return $rc; +} + +sub _set_ISA { + + #--------------------------------------------------------------------- + # set the ISA array for the class + # this method is for internal use only + #--------------------------------------------------------------------- + + my ($class, $log, @parents) = @_; + + # turn off strict here so we can get at the class @ISA + no strict 'refs'; + + $log->debug("\t\@ISA for $class currently contains ", + (join ", ", @{"${class}::ISA"})); + $log->debug("\tabout to merge ", (join ", ", @parents)); + + # only add classes to @ISA if they are not there already + my %seen; + + @{"${class}::ISA"} = grep !$seen{$_}++, (@{"${class}::ISA"}, @parents); + + return 1; +} + +#--------------------------------------------------------------------- +# Pure Perl configuration methods +#--------------------------------------------------------------------- + +sub get_pureperl_config { + my $r = shift; + my $cfg = {}; + no strict 'refs'; + foreach my $key ( + qw(DispatchPrefix DispatchExtras DispatchStat DispatchAUTOLOAD DispatchISA DispatchLocation DispatchRequire DispatchFilter DispatchUpperCase) + ) + { + my $arg = $r->dir_config($key); + next unless $arg; + &$key($cfg, undef, $arg); + } + return $cfg; +} + +#--------------------------------------------------------------------- +# Apache configuration methods +#--------------------------------------------------------------------- + +sub _new { + return bless {}, shift; +} + +sub DIR_CREATE { + my $class = shift; + my $self = $class->_new; + + $self->{_stat} = "Off"; # no reloading by default + $self->{_autoload} = 0; # no autloading by default + $self->{_require} = 0; # no require()ing by default + + # warn "inside DIR_CREATE"; + return $self; +} + +sub DIR_MERGE { + my ($parent, $current) = @_; + my %new = (%$parent, %$current); + + # warn "inside DIR_MERGE"; + return bless \%new, ref($parent); +} + +sub DispatchLocation { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_newloc} = $arg; +} + +sub DispatchPrefix { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_prefix} = $arg; +} + +sub DispatchExtras { + my ($cfg, $parms, $arg) = @_; + + if ($arg =~ m/^(Pre|Post|Error)$/i) { + push @{$cfg->{_extras}}, uc($arg) + unless grep /$arg/i, @{$cfg->{_extras}}; + } + else { + die "Invalid DispatchExtra $arg!"; + } +} + +sub DispatchISA { + my ($cfg, $parms, $arg) = @_; + + push @{$cfg->{_isa}}, $arg + unless grep /$arg/, @{$cfg->{_isa}}; +} + +sub DispatchStat { + my ($cfg, $parms, $arg) = @_; + + if ($arg =~ m/^(On|Off|ISA)$/i) { + $cfg->{_stat} = uc($arg); + } + else { + die "Invalid DispatchStat $arg!"; + } +} + +sub DispatchRequire { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_require} = $arg; +} + +sub DispatchFilter { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_filter} = $arg; +} + +sub DispatchAUTOLOAD { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_autoload} = $arg; +} + +sub DispatchUpperCase { + my ($cfg, $parms, $arg) = @_; + + $cfg->{_uppercase} = $arg; +} + +1; + +__END__ + +=head1 NAME + +Apache::Dispatch - call PerlHandlers with the ease of Registry scripts + +=head1 SYNOPSIS + +httpd.conf: + + PerlModule Apache::Dispatch + PerlModule Bar + + DispatchExtras Pre Post Error + DispatchStat On + DispatchISA "My::Utils" + DispatchAUTOLOAD Off + + <Location /Foo> + SetHandler perl-script + PerlHandler Apache::Dispatch + + DispatchPrefix Bar + DispatchFilter Off + </Location> + +=head1 DESCRIPTION + +Apache::Dispatch translates $r->uri into a class and method and runs +it as a PerlHandler. Basically, this allows you to call PerlHandlers +as you would Regsitry scripts without having to load your httpd.conf +with a slurry of <Location> tags. + +=head1 EXAMPLE + + in httpd.conf + + PerlModule Apache::Dispatch + PerlModule Bar + + <Location /Foo> + SetHandler perl-script + PerlHandler Apache::Dispatch + + DispatchPrefix Bar + </Location> + + in browser: + http://localhost/Foo/baz + + the results are the same as if your httpd.conf looked like: + <Location /Foo> + SetHandler perl-script + PerlHandler Bar->dispatch_baz + </Location> + +but with the additional security of protecting the class name from +the browser and keeping the method name from being called directly. +Because any class under the Bar:: hierarchy can be called, one +<Location> directive is able to handle all the methods of Bar, +Bar::Baz, etc... + +=head1 CONFIGURATION DIRECTIVES + + DispatchPrefix + The base class to be substituted for the $r->location part of the + uri. + + DispatchLocation + Using Apache::Dispatch from a <Directory> directive, either + directly or from a .htaccess file, will _require_ the use of + DispatchLocation, which defines the location from which + Apache::Dispatch will start class->method() translation. + For example: + + httpd.conf + DocumentRoot /usr/local/apache/htdocs + <Directory /usr/local/apache/htdocs/> + ... + <Directory> + + .htaccess (in /usr/local/apache/htdocs/Foo) + SetHandler perl-script + PerlHandler Apache::Dispatch + DispatchPrefix Baz + DispatchLocation /Foo + + This allows a request to /Foo/Bar/biff to properly map to + Baz::Bar->biff(). + + While intended specifically for <Directory> configurations, one + could use DispatchLocation to further obscure uri translations + within <Location> sections as well by changing the part of + the uri that is substitued with your module. + + DispatchExtras + An optional list of extra processing to enable per-request. If + the main handler is not a valid method call, the request is + declined prior to the execution of any of the extra methods. + + Pre - eval()s Foo->pre_dispatch($r) prior to dispatching the + uri. The $@ of the eval is not checked in any way. + + Post - eval()s Foo->post_dispatch($r) after dispatching the + uri. The $@ of the eval is not checked in any way. + + Error - If the main handler returns other than Apache2::Const::OK then + Foo->error_dispatch($r, $@) is called and return status + of it is returned instead. Unlike the pre and post + processing routines above, error_dispatch is not wrapped + in an eval, so if it dies, the Apache::Dispatch dies, + and Apache will process the error using ErrorDocument, + custom_response(), etc. + With error_dispatch() disabled, the return status of the + the main handler is returned to the client. + + DispatchRequire + An optional directive that enables require()ing of the module that + is the result of the uri to class->method translation. This allows + your configuration to be a bit more dynamic, but also decreases + security somewhat. And don't forget that you really should be + pre-loading frequently used modules in the parent process to reduce + overhead - DispatchRequire is a directive of conveinence. + + On - require() the module + + Off - Do not require() the module (Default) + + DispatchStat + An optional directive that enables reloading of the module that is + the result of the uri to class->method translation, similar to + Apache::Registry, Apache::Reload, or Apache::StatINC. + + On - Test the called package for modification and reload on + change + + Off - Do not test or reload the package (Default) + + ISA - Test the called package, and all other packages in the + called package's @ISA, and reload on change + + DispatchAUTOLOAD + An optional directive that enables unknown methods to use + AutoLoader. It may be applied on a per-server or per-location + basis and defaults to Off. Please see the special section on + AUTOLOAD below. + + On - Allow for methods to be defined in AUTOLOAD method + + Off - Turn off search for AUTOLOAD method (Default) + + DispatchISA + An optional list of parent classes you want your dispatched class + to inherit from. + + Dis... [truncated message content] |
|
From: Fred M. <fr...@ta...> - 2006-04-17 17:26:14
|
On Sun, 16 Apr 2006, Fred Moyer wrote: > handle both httpd and apxs options. This stuff probably accounts for the > bugs I encountered the other day with the changes to extra.last.conf.in. The blib section was definitely the cause of the server not starting, repeated it again last night with 2.0.55. Got the first test passing also, then I came up with a great idea to use t/lib/Apache, t/lib/Apache2 for the test lib namespaces. Changed that this morning but it broke the working test :( Will do a check in once I get the test working with the updated namespaces. |
|
From: Fred M. <fr...@re...> - 2006-04-16 09:23:57
|
I've been testing with Apache 2.2 and getting lots of core dumps when I called methods on $r <rips hair out>. And when I tried testing with 2.0.55 using APACHE_TEST_HTTPD=/path/to/2.0.55 it could not find mod_perl.so... But it worked when I also used APACHE_TEST_APXS=/path/to/2.0.55/apxs. Need to suggest APACHE_TEST_PATH option which points to /path/to/2.0.55/bin/ to handle both httpd and apxs options. This stuff probably accounts for the bugs I encountered the other day with the changes to extra.last.conf.in. |
|
From: Fred M. <fr...@ta...> - 2006-04-14 16:31:02
|
On Fri, 14 Apr 2006 7:37 am, Geoffrey Young wrote: > >> trunk/t/conf/extra.last.conf.in >> Modified: trunk/t/conf/extra.last.conf.in >> =================================================================== >> --- trunk/t/conf/extra.last.conf.in 2006-04-05 16:36:32 UTC (rev 12) >> +++ trunk/t/conf/extra.last.conf.in 2006-04-14 06:11:47 UTC (rev 13) >> @@ -1,9 +1,3 @@ >> -<Perl> >> - # stuff to get Apache::Test to recognize shared object files >> - local $^W = 0; >> - use blib; >> -</Perl> > > I'm pretty sure this was a remnant that was required before > extra.last.conf.in existed, so putting it there makes it redundant > (because > modperl_startup adds blib to @INC already). so removing it is the > right > thing I'd think. > > nevertheless, it shouldn't have prevented the test suite from running, > but > we'll save that bug for a later time :) Before the exact details fade from my mind, after trying a lot of different combinations to figure out what was wrong I determined that it was a problem with using both the blib pragma and apache directives together. One or the other worked fine. It was highly repeatable, but needless to say I found the easy way out and took it. Got to learn some new apache test tricks while debugging it though ;) |
|
From: Geoffrey Y. <ge...@mo...> - 2006-04-14 14:14:41
|
> trunk/t/conf/extra.last.conf.in > Modified: trunk/t/conf/extra.last.conf.in > =================================================================== > --- trunk/t/conf/extra.last.conf.in 2006-04-05 16:36:32 UTC (rev 12) > +++ trunk/t/conf/extra.last.conf.in 2006-04-14 06:11:47 UTC (rev 13) > @@ -1,9 +1,3 @@ > -<Perl> > - # stuff to get Apache::Test to recognize shared object files > - local $^W = 0; > - use blib; > -</Perl> I'm pretty sure this was a remnant that was required before extra.last.conf.in existed, so putting it there makes it redundant (because modperl_startup adds blib to @INC already). so removing it is the right thing I'd think. nevertheless, it shouldn't have prevented the test suite from running, but we'll save that bug for a later time :) --Geoff |
|
From: <phr...@us...> - 2006-04-14 06:32:49
|
Revision: 14 Author: phred_moyer Date: 2006-04-13 23:32:44 -0700 (Thu, 13 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=14&view=rev Log Message: ----------- - missed the Apache2 call in some <IfDefine APACHE2> sections. Modified Paths: -------------- trunk/t/conf/extra.last.conf.in Modified: trunk/t/conf/extra.last.conf.in =================================================================== --- trunk/t/conf/extra.last.conf.in 2006-04-14 06:11:47 UTC (rev 13) +++ trunk/t/conf/extra.last.conf.in 2006-04-14 06:32:44 UTC (rev 14) @@ -47,7 +47,7 @@ SetHandler perl-script <IfDefine APACHE2> - PerlResponseHandler Apache::Dispatch + PerlResponseHandler Apache2::Dispatch </IfDefine> <IfDefine APACHE1> PerlHandler Apache::Dispatch @@ -78,7 +78,7 @@ SetHandler perl-script <IfDefine APACHE2> - PerlResponseHandler Apache::Dispatch + PerlResponseHandler Apache2::Dispatch </IfDefine> <IfDefine APACHE1> PerlHandler Apache::Dispatch This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <phr...@us...> - 2006-04-14 06:11:51
|
Revision: 13 Author: phred_moyer Date: 2006-04-13 23:11:47 -0700 (Thu, 13 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=13&view=rev Log Message: ----------- - remove Perl section which disables warnings and uses blib For some odd reason, make test would not start the server with this section. I don't currently have any idea why, even though I was able to start the server in single user mode, and under -debug using gdb and the Perl debugger. Regardless, things are finally moving forward here, that was a head trip of a bug. Modified Paths: -------------- trunk/t/conf/extra.last.conf.in Modified: trunk/t/conf/extra.last.conf.in =================================================================== --- trunk/t/conf/extra.last.conf.in 2006-04-05 16:36:32 UTC (rev 12) +++ trunk/t/conf/extra.last.conf.in 2006-04-14 06:11:47 UTC (rev 13) @@ -1,9 +1,3 @@ -<Perl> - # stuff to get Apache::Test to recognize shared object files - local $^W = 0; - use blib; -</Perl> - <IfDefine APACHE2> PerlModule Apache2::Dispatch <Perl> This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <phr...@us...> - 2006-04-05 16:36:46
|
Revision: 12 Author: phred_moyer Date: 2006-04-05 09:36:32 -0700 (Wed, 05 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=12&view=rev Log Message: ----------- Fix errorneous IfDefines using APACHE to APACHE1. Thanks to geoff for the spot. Modified Paths: -------------- trunk/t/conf/extra.last.conf.in Modified: trunk/t/conf/extra.last.conf.in =================================================================== --- trunk/t/conf/extra.last.conf.in 2006-04-05 08:30:06 UTC (rev 11) +++ trunk/t/conf/extra.last.conf.in 2006-04-05 16:36:32 UTC (rev 12) @@ -55,7 +55,7 @@ <IfDefine APACHE2> PerlResponseHandler Apache::Dispatch </IfDefine> - <IfDefine APACHE> + <IfDefine APACHE1> PerlHandler Apache::Dispatch </IfDefine> @@ -70,7 +70,7 @@ <IfDefine APACHE2> PerlResponseHandler Apache2::Dispatch </IfDefine> - <IfDefine APACHE> + <IfDefine APACHE1> PerlHandler Apache::Dispatch </IfDefine> @@ -86,7 +86,7 @@ <IfDefine APACHE2> PerlResponseHandler Apache::Dispatch </IfDefine> - <IfDefine APACHE> + <IfDefine APACHE1> PerlHandler Apache::Dispatch </IfDefine> This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: Geoffrey Y. <ge...@mo...> - 2006-04-05 13:06:54
|
> <IfDefine APACHE> > PerlHandler Apache::Dispatch I'm pretty sure that ought to be <IfDefine APACHE1> --Geoff |
|
From: <phr...@us...> - 2006-04-05 08:30:12
|
Revision: 11 Author: phred_moyer Date: 2006-04-05 01:30:06 -0700 (Wed, 05 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=11&view=rev Log Message: ----------- Fix erroneous package name in IfDefine. Added use lib pragmas for mp1/mp2 specific testing lib dirs. Modified Paths: -------------- trunk/t/conf/extra.last.conf.in Modified: trunk/t/conf/extra.last.conf.in =================================================================== --- trunk/t/conf/extra.last.conf.in 2006-04-02 08:37:23 UTC (rev 10) +++ trunk/t/conf/extra.last.conf.in 2006-04-05 08:30:06 UTC (rev 11) @@ -6,9 +6,15 @@ <IfDefine APACHE2> PerlModule Apache2::Dispatch + <Perl> + use lib 't/lib/mp2'; + </Perl> </IfDefine> <IfDefine APACHE1> PerlModule Apache::Dispatch + <Perl> + use lib 't/lib/mp1'; + </Perl> </IfDefine> DispatchDebug 2 @@ -62,7 +68,7 @@ SetHandler perl-script <IfDefine APACHE2> - PerlResponseHandler Apache::Dispatch + PerlResponseHandler Apache2::Dispatch </IfDefine> <IfDefine APACHE> PerlHandler Apache::Dispatch This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: Fred M. <fr...@re...> - 2006-04-04 16:22:59
|
I've managed to get some basic functionality working over the last few days. Having a problem getting the apache-test server to start but its probably my wacky laptop config, I've been debugging by starting the server in single mode and telnetting to it. Should have a first working a2::d checkin this week at some point (not sure if the filtering will be working at that point.) Fred |
|
From: <phr...@us...> - 2006-04-02 08:37:32
|
Revision: 10 Author: phred_moyer Date: 2006-04-02 00:37:23 -0800 (Sun, 02 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=10&view=rev Log Message: ----------- Custom configuration directives launch the interpreter, therefore these directives should be in extra.last.conf.in. Added Paths: ----------- trunk/t/conf/extra.last.conf.in Removed Paths: ------------- trunk/t/conf/extra.conf.in Deleted: trunk/t/conf/extra.conf.in =================================================================== --- trunk/t/conf/extra.conf.in 2006-03-31 08:01:03 UTC (rev 9) +++ trunk/t/conf/extra.conf.in 2006-04-02 08:37:23 UTC (rev 10) @@ -1,91 +0,0 @@ -<Perl> - # stuff to get Apache::Test to recognize shared object files - local $^W = 0; - use blib; -</Perl> - -<IfDefine APACHE2> - PerlModule Apache2::Dispatch -</IfDefine> -<IfDefine APACHE1> - PerlModule Apache::Dispatch -</IfDefine> - -DispatchDebug 2 - -<Location /plain> - SetHandler perl-script - - <IfDefine APACHE2> - PerlResponseHandler Apache2::Dispatch - </IfDefine> - <IfDefine APACHE1> - PerlHandler Apache::Dispatch - </IfDefine> - - DispatchPrefix Foo - DispatchRequire On -</Location> - -<Location /filtered> - SetHandler perl-script - - <IfDefine APACHE2> - PerlResponseHandler Apache2::Dispatch Foo::Filter - </IfDefine> - <IfDefine APACHE1> - PerlHandler Apache::Dispatch Foo::Filter - </IfDefine> - - DispatchPrefix Foo - DispatchFilter On - DispatchRequire On - DispatchExtras Pre Post -</Location> - -<Location /extras> - SetHandler perl-script - - <IfDefine APACHE2> - PerlResponseHandler Apache::Dispatch - </IfDefine> - <IfDefine APACHE> - PerlHandler Apache::Dispatch - </IfDefine> - - DispatchPrefix Foo - DispatchRequire On - DispatchExtras Pre Error -</Location> - -<Location /oo> - SetHandler perl-script - - <IfDefine APACHE2> - PerlResponseHandler Apache::Dispatch - </IfDefine> - <IfDefine APACHE> - PerlHandler Apache::Dispatch - </IfDefine> - - DispatchPrefix Foo - DispatchRequire On - DispatchAUTOLOAD On - DispatchISA Foo::Parent -</Location> - -<Location /newloc> - SetHandler perl-script - - <IfDefine APACHE2> - PerlResponseHandler Apache::Dispatch - </IfDefine> - <IfDefine APACHE> - PerlHandler Apache::Dispatch - </IfDefine> - - DispatchPrefix Foo - DispatchLocation /BLARG - DispatchRequire On -</Location> - Copied: trunk/t/conf/extra.last.conf.in (from rev 9, trunk/t/conf/extra.conf.in) =================================================================== --- trunk/t/conf/extra.last.conf.in (rev 0) +++ trunk/t/conf/extra.last.conf.in 2006-04-02 08:37:23 UTC (rev 10) @@ -0,0 +1,91 @@ +<Perl> + # stuff to get Apache::Test to recognize shared object files + local $^W = 0; + use blib; +</Perl> + +<IfDefine APACHE2> + PerlModule Apache2::Dispatch +</IfDefine> +<IfDefine APACHE1> + PerlModule Apache::Dispatch +</IfDefine> + +DispatchDebug 2 + +<Location /plain> + SetHandler perl-script + + <IfDefine APACHE2> + PerlResponseHandler Apache2::Dispatch + </IfDefine> + <IfDefine APACHE1> + PerlHandler Apache::Dispatch + </IfDefine> + + DispatchPrefix Foo + DispatchRequire On +</Location> + +<Location /filtered> + SetHandler perl-script + + <IfDefine APACHE2> + PerlResponseHandler Apache2::Dispatch Foo::Filter + </IfDefine> + <IfDefine APACHE1> + PerlHandler Apache::Dispatch Foo::Filter + </IfDefine> + + DispatchPrefix Foo + DispatchFilter On + DispatchRequire On + DispatchExtras Pre Post +</Location> + +<Location /extras> + SetHandler perl-script + + <IfDefine APACHE2> + PerlResponseHandler Apache::Dispatch + </IfDefine> + <IfDefine APACHE> + PerlHandler Apache::Dispatch + </IfDefine> + + DispatchPrefix Foo + DispatchRequire On + DispatchExtras Pre Error +</Location> + +<Location /oo> + SetHandler perl-script + + <IfDefine APACHE2> + PerlResponseHandler Apache::Dispatch + </IfDefine> + <IfDefine APACHE> + PerlHandler Apache::Dispatch + </IfDefine> + + DispatchPrefix Foo + DispatchRequire On + DispatchAUTOLOAD On + DispatchISA Foo::Parent +</Location> + +<Location /newloc> + SetHandler perl-script + + <IfDefine APACHE2> + PerlResponseHandler Apache::Dispatch + </IfDefine> + <IfDefine APACHE> + PerlHandler Apache::Dispatch + </IfDefine> + + DispatchPrefix Foo + DispatchLocation /BLARG + DispatchRequire On +</Location> + This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: Geoffrey Y. <ge...@mo...> - 2006-03-31 18:14:27
|
testing ability to post... move along. |
|
From: Geoffrey Y. <ge...@mo...> - 2006-03-31 16:24:00
|
subscribe |
|
From: <phr...@us...> - 2006-03-31 08:01:10
|
Revision: 9 Author: phred_moyer Date: 2006-03-31 00:01:03 -0800 (Fri, 31 Mar 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=9&view=rev Log Message: ----------- Add mp2 compatiblity. Use different approaches for mp1 and mp2, mp2 approache inspired by Apache::Peek. Merge these compatibility changes with an updated mp1 Makefile.PL from Thomas Klausner. Modified Paths: -------------- trunk/Makefile.PL Modified: trunk/Makefile.PL =================================================================== --- trunk/Makefile.PL 2006-03-31 07:50:07 UTC (rev 8) +++ trunk/Makefile.PL 2006-03-31 08:01:03 UTC (rev 9) @@ -1,129 +1,145 @@ -package Apache::Dispatch; +#!perl -use ExtUtils::MakeMaker; - require 5.005; -eval { - require Apache::ExtUtils; - require Apache::src; -}; +use strict; +use warnings FATAL => 'all'; -my %makefile_params=( - 'NAME' => __PACKAGE__, - 'VERSION_FROM' => 'Dispatch.pm', - ); +## which mp version ( 1.2x or 2.0.x) +my ($mp_wanted, $mp_ver) = &get_mp_ver(); - +print STDERR "Using mod_perl/$mp_ver\n\n"; -if ($@ || $ENV{DISPATCH_PUREPERL}) { - print "\nBuilding without Custom Apache Directives, use 'PerlSetVar' for configuration.\n\n"; +my %prereq = ('Apache::Test' => "1.23"); - $makefile_params{'PL_FILES'}={'set_pureperl.PL'=>'1'}; - $makefile_params{'C'}=[]; - -} else { - print "\nBuilding with Custom Apache Directives ('DispatchPrefix'). You +my %makefile_params = ( + 'VERSION' => '0.10', + 'PREREQ_PM' => \%prereq, + ); + +# enable "make test" +require Apache::TestMM; +Apache::TestMM->import(qw(test clean)); + +# accept configs from command line. +Apache::TestMM::filter_args(); + +my @scripts = qw(t/TEST); +Apache::TestMM::generate_script(@scripts); + +$makefile_params{clean} = {FILES => "@scripts"}; + +if ($mp_wanted == 2) { # mod_perl2 specific makefile + $prereq{'mod_perl'} = 1.99023; # this covers the naming change + $makefile_params{'NAME'} = 'Apache2::Dispatch'; + + require ModPerl::MM; + ModPerl::MM::WriteMakefile(%makefile_params); +} + +elsif ($mp_wanted != 2) { # mod_perl1 specific makefile + + eval { + require Apache::ExtUtils; + require Apache::src; + }; + + if ($@ || $ENV{DISPATCH_PUREPERL}) { + print +"\nBuilding without Custom Apache Directives, use 'PerlSetVar' for configuration.\n\n"; + + $makefile_params{'PL_FILES'} = {'set_pureperl.PL' => '1'}; + $makefile_params{'C'} = []; + + } + else { + print "\nBuilding with Custom Apache Directives ('DispatchPrefix'). You will need a C compiler and Apache/mod_perl sources.\n\n"; - - import Apache::ExtUtils qw(command_table); - - my @directives = ( - #------------------------------------------------------------------ - # DispatchPrefix defines the base class for a given <Location> - #------------------------------------------------------------------ - { name => 'DispatchPrefix', - errmsg => 'a class to be used as the base class', - args_how => 'TAKE1', - req_override => 'OR_ALL', }, + import Apache::ExtUtils qw(command_table); - #------------------------------------------------------------------ - # DispatchExtras defines the extra dispatch methods to enable - #------------------------------------------------------------------ - { name => 'DispatchExtras', - errmsg => 'choose any of: Pre, Post, or Error', - args_how => 'ITERATE', - req_override => 'OR_ALL', }, + require Apache::Dispatch; + my $directives = Apache::Dispatch->directives; + Apache::Extutils::command_table($directives); - #------------------------------------------------------------------ - # DispatchStat enables module testing and subsequent reloading - #------------------------------------------------------------------ - { name => 'DispatchStat', - errmsg => 'choose one of On, Off, or ISA', - args_how => 'TAKE1', - req_override => 'OR_ALL', }, + my $inc = Apache::src->new->inc; + die "Can't find mod_perl header files installed" unless $inc; - #------------------------------------------------------------------ - # DispatchAUTOLOAD defines AutoLoader behavior - #------------------------------------------------------------------ - { name => 'DispatchAUTOLOAD', - errmsg => 'choose one of On or Off', - args_how => 'FLAG', - req_override => 'OR_ALL', }, + $makefile_params{'INC'} = $inc; + $makefile_params{'PL_FILES'} = {'set_pureperl.PL' => '0'}; + $makefile_params{'PREREQ_PM'} = {mod_perl => 1.2401,}; + $makefile_params{'clean'} = {FILES => '*.xs*'}; + $makefile_params{'NAME'} = 'Apache2::Dispatch'; - #------------------------------------------------------------------ - # DispatchDebug defines debugging verbosity - #------------------------------------------------------------------ - { name => 'DispatchDebug', - errmsg => 'numeric verbosity level', - args_how => 'TAKE1', - req_override => 'OR_ALL', }, + require ExtUtils::MakeMaker; + ExtUtils::MakeMaker::WriteMakefile( + INC => $inc, + LIBS => [''], + %makefile_params, + ); + } +} - #------------------------------------------------------------------ - # DispatchISA is a list of modules your module should inherit from - #------------------------------------------------------------------ - { name => 'DispatchISA', - errmsg => 'a list of parent modules', - args_how => 'ITERATE', - req_override => 'OR_ALL', }, +# The next sub inspired by Apache::Peek 1.05 - #------------------------------------------------------------------ - # DispatchLocation allows you to redefine the <Location> - #------------------------------------------------------------------ - { name => 'DispatchLocation', - errmsg => 'a location to replace the current <Location>', - args_how => 'TAKE1', - req_override => 'OR_ALL', }, +sub get_mp_ver { - #------------------------------------------------------------------ - # DispatchRequire require()s the class - #------------------------------------------------------------------ - { name => 'DispatchRequire', - errmsg => 'choose one of On or Off', - args_how => 'FLAG', - req_override => 'OR_ALL', }, + my $flag = 0; + my @args = (); - #------------------------------------------------------------------ - # DispatchFilter makes the dispatched handler Apache::Filter aware - #------------------------------------------------------------------ - { name => 'DispatchFilter', - errmsg => 'choose one of On or Off', - args_how => 'FLAG', - req_override => 'OR_ALL', }, + while (my $arg = shift @ARGV) { + if ($arg =~ /^MOD_PERL=([12])$/) { + $flag = $1; + } + else { + push @args, $arg; + } + } + @ARGV = @args; - #------------------------------------------------------------------ - # DispatchUppercase converts the first char of a class to uppercase - #------------------------------------------------------------------ - { name => 'DispatchUpperCase', - errmsg => 'choose one of On or Off', - args_how => 'FLAG', - req_override => 'OR_ALL', }, + # check %ENV + my $env = exists $ENV{MOD_PERL} ? $ENV{MOD_PERL} : 0; + # check for contradicting requirements + if ($env && $flag && $flag != $env) { + die <<EOF; +Can\'t decide which mod_perl version should be used, since you have +supplied contradicting requirements: + enviroment variable MOD_PERL=$env + Makefile.PL option MOD_PERL=$flag +EOF + } - ); + my $wanted = 2; ## default to wanting mp2 + $wanted = 1 if $env == 1 || $flag == 1; - command_table(\@directives); + my $mp_ver; - $makefile_params{'PL_FILES'}={'set_pureperl.PL'=>'0'}; - - $makefile_params{'INC'}=Apache::src->new->inc; - $makefile_params{'PREREQ_PM'}={ mod_perl => 1.2401, }; - $makefile_params{'clean'}={ FILES => '*.xs*' }; + if ($wanted == 2) { + eval { require mod_perl2 }; + my $req_ver = 1.999022; + if ($mod_perl2::VERSION < $req_ver || $@) { + die +"mod_perl2 required version is $req_ver, you have $mod_perl2::VERSION. Please upgrade to continue."; + } + else { + $mp_ver = $mod_perl2::VERSION; + } + } + else { + eval { require mod_perl }; + no warnings qw(uninitialized); + if ($mod_perl::VERSION > 1.99 || $@) { + die "You don't seem to have mod_perl 1.0 installed"; + } + else { + $mp_ver = $mod_perl::VERSION; + } + } + + return ($wanted, $mp_ver); } -WriteMakefile(%makefile_params); - __END__ open (FH,catfile(qw(blib lib Apache Dispatch.pm))) || die "cannot read Dispatch.pm: $!"; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: Fred M. <fr...@ta...> - 2006-03-28 20:49:20
|
obligatory test message |
