[Apache-dispatch-devel] SF.net SVN: apache-dispatch: [29] trunk
Brought to you by:
geoffrey_young,
phred_moyer
Menu
▾
▴
[Apache-dispatch-devel] SF.net SVN: apache-dispatch: [29] trunk
|
From: <phr...@us...> - 2006-04-23 06:01:34
|
Revision: 29 Author: phred_moyer Date: 2006-04-22 23:01:28 -0700 (Sat, 22 Apr 2006) ViewCVS: http://svn.sourceforge.net/apache-dispatch/?rev=29&view=rev Log Message: ----------- - Apache*::Dispatch modules now inherit common methods from Apache::Dispatch::Util - add test libs for Apache::Foo et all - update changelog to reflect recent changes Modified Paths: -------------- trunk/Changes trunk/MANIFEST trunk/lib/Apache/Dispatch/Util.pm trunk/lib/Apache/Dispatch.pm trunk/lib/Apache2/Dispatch.pm Added Paths: ----------- trunk/t/lib/Apache/ trunk/t/lib/Apache/Bar.pm trunk/t/lib/Apache/Foo.pm Modified: trunk/Changes =================================================================== --- trunk/Changes 2006-04-23 03:40:39 UTC (rev 28) +++ trunk/Changes 2006-04-23 06:01:28 UTC (rev 29) @@ -1,8 +1,17 @@ Revision history for Perl extension Apache::Dispatch 0.10 05.07.2001 + - move common methods to Apache::Dispatch::Util and adjust @ISA for + Apache*::Dispatch modules to use common methods via inheritance - fred + - deprecated $Apache::Dispatch::DEBUG directive per dev notes in favor + of DispatchDebug, which accepts the same arguments, see pod - fred + - mod_perl2 compatibility via Apache2::Dispatch - fred + - source code now under subversion at + http://svn.sourceforge.net/viewcvs.cgi/apache-dispatch/ - geoff, domm + - project moved to http://sourceforge.net/projects/apache-dispatch - geoff + * new maintainer: Fred Moyer <fr...@re...> - pass $rc to error handler to allow for finer grained error handling - - print "Using/Exiting A::D" only if $debub>=1 + - print "Using/Exiting A::D" only if $debug>=1 * new maintainer: Thomas Klausner, do...@zs... - fixed DispatchISA bug that kept adding the same classes to @ISA (Barrie Slaymaker) Modified: trunk/MANIFEST =================================================================== --- trunk/MANIFEST 2006-04-23 03:40:39 UTC (rev 28) +++ trunk/MANIFEST 2006-04-23 06:01:28 UTC (rev 29) @@ -1,10 +1,14 @@ Changes MANIFEST Makefile.PL -Dispatch.pm README ToDo -eg/Foo.pm -eg/Bar.pm -eg/Foo/Foo.pm -eg/Foo/Bar.pm +lib/Apache/Dispatch.pm +lib/Apache/Dispatch/Util.pm +lib/Apache2/Dispatch.pm +t/lib/Apache/Foo/Bar.pm +t/lib/Apache/Foo/Foo.pm +t/lib/Apache/Bar.pm +t/lib/Apache/Foo.pm +t/lib/Apache2/Foo/Bar.pm +t/lib/Apache2/Foo.pm Modified: trunk/lib/Apache/Dispatch/Util.pm =================================================================== --- trunk/lib/Apache/Dispatch/Util.pm 2006-04-23 03:40:39 UTC (rev 28) +++ trunk/lib/Apache/Dispatch/Util.pm 2006-04-23 06:01:28 UTC (rev 29) @@ -23,7 +23,7 @@ =back =cut - + my @directives = ( #------------------------------------------------------------------ @@ -67,6 +67,16 @@ }, #------------------------------------------------------------------ + # 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 #------------------------------------------------------------------ { @@ -117,6 +127,9 @@ }, ); +# create global hash to hold the modification times of the modules +my %stat = (); + =head1 METHODS =over 4 @@ -144,10 +157,322 @@ =cut sub directives { - my $class = shift; - return wantarray ? @directives : \@directives; + my $class = shift; + return wantarray ? @directives : \@directives; } +=item bogus_uri + +=cut + +sub bogus_uri { + my ($class, $uri) = @_; + if ($uri =~ m![^\w/-]!) { + return 1; + } + return; +} +#********************************************************************* +# the below methods are not part of the external API +#********************************************************************* + +sub _stat { + + #--------------------------------------------------------------------- + # stat and reload the module if it has changed... + # this method is for internal use only + #--------------------------------------------------------------------- + + my $pkg = shift; + 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("Apache2::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("Apache2::Dispatch: $module failed reload! $@"); + return; + } + elsif (!$@) { + $log->debug("\t$module reloaded"); + } + $stat{$module} = $mtime; + } + else { + $log->info("\t$module not modified"); + } + } + else { + $log->warn("Apache2::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 $pkg; + 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; +} + +#--------------------------------------------------------------------- +# 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 _translate_uri { + + #--------------------------------------------------------------------- + # take the uri and return a class and method + # this method is for internal use only + #--------------------------------------------------------------------- + + my $pkg = shift; + 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 $pkg = shift; + 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 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; +} + =pod =back Modified: trunk/lib/Apache/Dispatch.pm =================================================================== --- trunk/lib/Apache/Dispatch.pm 2006-04-23 03:40:39 UTC (rev 28) +++ trunk/lib/Apache/Dispatch.pm 2006-04-23 06:01:28 UTC (rev 29) @@ -16,30 +16,18 @@ use mod_perl 1.2401; use Apache::Constants qw(OK DECLINED SERVER_ERROR); use Apache::Log; +use Apache::Dispatch::Util; +push @Apache::Dispatch::ISA, qw(Apache::Dispatch::Util); -$Apache::Dispatch::PUREPERL=0; # set during perl Makefile.PL +$Apache::Dispatch::PUREPERL = 0; # 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); - __PACKAGE__->bootstrap($VERSION); + __PACKAGE__->bootstrap($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 { #--------------------------------------------------------------------- @@ -60,38 +48,25 @@ || $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 $debug = $dcfg->{_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 $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; + $log->info("Using Apache::Dispatch") if $debug; # redefine $r as necessary for Apache::Filter 1.013 and above if ($filter) { @@ -102,19 +77,19 @@ # 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 $debug > 1; # 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"); + if (__PACKAGE__->bogus_uri($uri)) { + if ($debug) { + $log->info("\t$uri has bogus characters..."); + $log->info("Exiting Apache::Dispatch"); + } return DECLINED; } @@ -149,7 +124,7 @@ #--------------------------------------------------------------------- my ($class, $method) = - _translate_uri($r, $prefix, $new_location, $log, $debug); + __PACKAGE__->_translate_uri($r, $prefix, $new_location, $log, $debug); unless ($class && $method) { $log->info("\tclass and method could not be discovered") @@ -171,7 +146,7 @@ #--------------------------------------------------------------------- if (@parents) { - $rc = _set_ISA($class, $log, $debug, @parents); + $rc = __PACKAGE__->_set_ISA($class, $log, $debug, @parents); unless ($rc) { $log->error("\tDispatchISA did not return successfully!"); @@ -206,7 +181,7 @@ #--------------------------------------------------------------------- if ($stat eq "ON") { - $rc = _stat($class, $log, $debug); + $rc = __PACKGE__->_stat($class, $log, $debug); unless ($rc) { $log->error("\tDispatchStat did not return successfully!"); @@ -215,7 +190,7 @@ } } elsif ($stat eq "ISA") { - $rc = _recurse_stat($class, $log, $debug); + $rc = __PACKAGE__->_recurse_stat($class, $log, $debug); unless ($rc) { $log->error("\tDispatchStat did not return successfully!"); @@ -229,7 +204,7 @@ # if not, decline the request #--------------------------------------------------------------------- - my $handler = _check_dispatch($object, $method, $autoload, $log, $debug); + my $handler = __PACKAGE__->_check_dispatch($object, $method, $autoload, $log, $debug); if ($handler) { $log->info("\t$uri was translated into $class->$method") @@ -248,16 +223,16 @@ foreach my $extra (@extras) { if ($extra eq "PRE") { $prehandler = - _check_dispatch($object, "pre_dispatch", $autoload, $log, $debug); + __PACKAGE__->_check_dispatch($object, "pre_dispatch", $autoload, $log, $debug); } elsif ($extra eq "POST") { $posthandler = - _check_dispatch($object, "post_dispatch", $autoload, $log, + __PACKAGE__->_check_dispatch($object, "post_dispatch", $autoload, $log, $debug); } elsif ($extra eq "ERROR") { $errorhandler = - _check_dispatch($object, "error_dispatch", $autoload, $log, + __PACKAGE__->_check_dispatch($object, "error_dispatch", $autoload, $log, $debug); } } @@ -298,210 +273,6 @@ # 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 #--------------------------------------------------------------------- @@ -521,111 +292,6 @@ 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__ @@ -794,13 +460,10 @@ 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. + DispatchDebug - DEPRECATED + Per development notes this directive has been deprecated as of + Apache::Dispatch 0.10. The debugging verbosity is controlled using + the Apache LogLevel directive. =head1 SPECIAL CODING GUIDELINES Modified: trunk/lib/Apache2/Dispatch.pm =================================================================== --- trunk/lib/Apache2/Dispatch.pm 2006-04-23 03:40:39 UTC (rev 28) +++ trunk/lib/Apache2/Dispatch.pm 2006-04-23 06:01:28 UTC (rev 29) @@ -2,35 +2,28 @@ #--------------------------------------------------------------------- # -# usage: PerlHandler Apache::Dispatch +# usage: PerlHandler Apache2::Dispatch # #--------------------------------------------------------------------- use strict; use warnings; -$Apache2::Dispatch::VERSION = '0.15'; +$Apache2::Dispatch::VERSION = '0.10'; 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 (); +use Apache2::Log (); +use Apache2::Module (); +use Apache2::RequestRec (); +use Apache2::RequestUtil (); +use Apache::Dispatch::Util; +push @Apache2::Dispatch::ISA, qw(Apache::Dispatch::Util); -# Read server config and use this if appropriate -use Data::Dumper; - # Initialize the directives -my $directives = Apache::Dispatch::Util->directives(); +my $directives = __PACKAGE__->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 { #--------------------------------------------------------------------- @@ -40,39 +33,25 @@ # 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); - } + $dcfg = + Apache2::Module::get_config(__PACKAGE__, $r->server, $r->per_dir_config); 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 $debug = $dcfg->{_debug} || 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 $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); #--------------------------------------------------------------------- @@ -81,7 +60,6 @@ $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"); @@ -95,46 +73,54 @@ $log = $r->server->log; } - $log->debug("\tchecking $uri for possible dispatch..."); + $log->debug("\tchecking $uri for possible dispatch...") + if $debug > 1; # 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"); + if (__PACKAGE__->bogus_uri($uri)) { + if ($debug) { + + $log->info("\t$uri has bogus characters..."); + $log->info("Exiting Apache2::Dispatch"); + } return Apache2::Const::DECLINED; } + if ($debug > 1) { + $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\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"), + ); + } - $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); + my ($class, $method) = + __PACKAGE__->_translate_uri($r, $prefix, $new_location, $log, $debug); unless ($class && $method) { $log->debug("\tclass and method could not be discovered"); - $log->debug("Exiting Apache::Dispatch"); + $log->debug("Exiting Apache2::Dispatch"); return Apache2::Const::DECLINED; } @@ -151,11 +137,11 @@ #--------------------------------------------------------------------- if (@parents) { - $rc = _set_ISA($class, $log, @parents); + $rc = __PACKAGE__->_set_ISA($class, $log, @parents); unless ($rc) { $log->error("\tDispatchISA did not return successfully!"); - $log->info("Exiting Apache::Dispatch"); + $log->info("Exiting Apache2::Dispatch"); return Apache2::Const::DECLINED; } } @@ -171,7 +157,7 @@ if ($@) { $log->warn("\tcould not require $class: $@"); - $log->info("Exiting Apache::Dispatch"); + $log->info("Exiting Apache2::Dispatch"); return Apache2::Const::DECLINED; } else { @@ -184,20 +170,20 @@ #--------------------------------------------------------------------- if ($stat eq "ON") { - $rc = _stat($class, $log); + $rc = __PACKAGE__->_stat($class, $log); unless ($rc) { $log->error("\tDispatchStat did not return successfully!"); - $log->info("Exiting Apache::Dispatch"); + $log->info("Exiting Apache2::Dispatch"); return Apache2::Const::DECLINED; } } elsif ($stat eq "ISA") { - $rc = _recurse_stat($class, $log); + $rc = __PACKAGE__->_recurse_stat($class, $log); unless ($rc) { $log->error("\tDispatchStat did not return successfully!"); - $log->info("Exiting Apache::Dispatch"); + $log->info("Exiting Apache2::Dispatch"); return Apache2::Const::DECLINED; } } @@ -207,14 +193,14 @@ # if not, decline the request #--------------------------------------------------------------------- - my $handler = _check_dispatch($object, $method, $autoload, $log); + my $handler = __PACKAGE__->_check_dispatch($object, $method, $autoload, $log, $debug); 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"); + $log->info("Exiting Apache2::Dispatch"); return Apache2::Const::DECLINED; } @@ -224,15 +210,15 @@ foreach my $extra (@extras) { if ($extra eq "PRE") { $prehandler = - _check_dispatch($object, "pre_dispatch", $autoload, $log); + __PACKAGE__->_check_dispatch($object, "pre_dispatch", $autoload, $log); } elsif ($extra eq "POST") { $posthandler = - _check_dispatch($object, "post_dispatch", $autoload, $log); + __PACKAGE__->_check_dispatch($object, "post_dispatch", $autoload, $log); } elsif ($extra eq "ERROR") { $errorhandler = - _check_dispatch($object, "error_dispatch", $autoload, $log); + __PACKAGE__->_check_dispatch($object, "error_dispatch", $autoload, $log); } } @@ -260,342 +246,26 @@ # wrap up... #--------------------------------------------------------------------- - $log->info("\tApache::Dispatch is returning $rc"); + $log->info("\tApache2::Dispatch is returning $rc"); - $log->info("Exiting Apache::Dispatch"); + $log->info("Exiting Apache2::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 +Apache2::Dispatch - call PerlHandlers with the ease of Registry scripts =head1 SYNOPSIS httpd.conf: - PerlModule Apache::Dispatch + PerlModule Apache2::Dispatch PerlModule Bar DispatchExtras Pre Post Error @@ -605,7 +275,7 @@ <Location /Foo> SetHandler perl-script - PerlHandler Apache::Dispatch + PerlHandler Apache2::Dispatch DispatchPrefix Bar DispatchFilter Off @@ -613,7 +283,7 @@ =head1 DESCRIPTION -Apache::Dispatch translates $r->uri into a class and method and runs +Apache2::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. @@ -622,12 +292,12 @@ in httpd.conf - PerlModule Apache::Dispatch + PerlModule Apache2::Dispatch PerlModule Bar <Location /Foo> SetHandler perl-script - PerlHandler Apache::Dispatch + PerlHandler Apache2::Dispatch DispatchPrefix Bar </Location> @@ -654,10 +324,10 @@ uri. DispatchLocation - Using Apache::Dispatch from a <Directory> directive, either + Using Apache2::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. + Apache2::Dispatch will start class->method() translation. For example: httpd.conf @@ -668,7 +338,7 @@ .htaccess (in /usr/local/apache/htdocs/Foo) SetHandler perl-script - PerlHandler Apache::Dispatch + PerlHandler Apache2::Dispatch DispatchPrefix Baz DispatchLocation /Foo @@ -695,7 +365,7 @@ 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, + in an eval, so if it dies, the Apache2::Dispatch dies, and Apache will process the error using ErrorDocument, custom_response(), etc. With error_dispatch() disabled, the return status of the @@ -753,7 +423,7 @@ =head1 SPECIAL CODING GUIDELINES -Migrating to Apache::Dispatch is relatively painless - it requires +Migrating to Apache2::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 @@ -761,10 +431,10 @@ 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 +ordinary mod_perl handlers, for Apache2::Dispatch there is no default method (with a tiny exception - see NOTES below). -Apache::Dispatch uses object oriented calls behind the scenes. This +Apache2::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 @@ -779,7 +449,7 @@ my $r = Apache->request; } -If you want to use the handler unmodified outside of Apache::Dispatch, +If you want to use the handler unmodified outside of Apache2::Dispatch, you must do three things: prototype your handler: @@ -809,19 +479,19 @@ =head1 FILTERING -Apache::Dispatch provides for output filtering using Apache::Filter +Apache2::Dispatch provides for output filtering using Apache::Filter 1.013 and above. <Location /Foo> SetHandler perl-script - PerlHandler Apache::Dispatch Apache::Compress + PerlHandler Apache2::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 +the chain - Apache2::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. @@ -864,7 +534,7 @@ 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. +[a-zA-Z0-9_/-] Apache2::Dispatch declines to handle the request. Like everything in perl, the package names are case sensitive. @@ -880,7 +550,7 @@ =head1 FEATURES/BUGS -If a module fails reload under DispatchStat, Apache::Dispatch declines +If a module fails reload under DispatchStat, Apache2::Dispatch declines the request. This might change to SERVER_ERROR in the future... =head1 SEE ALSO Added: trunk/t/lib/Apache/Bar.pm =================================================================== --- trunk/t/lib/Apache/Bar.pm (rev 0) +++ trunk/t/lib/Apache/Bar.pm 2006-04-23 06:01:28 UTC (rev 29) @@ -0,0 +1,35 @@ +package Foo::Bar; +use Apache::Constants qw( OK SERVER_ERROR ); +use strict; + +@Foo::Bar::ISA = qw(Foo); + +sub dispatch_baz { + my $r = Apache->request; + $r->send_http_header('text/plain'); + $r->print("Foo::Bar->dispatch_baz()"); + print STDERR "Foo->dispatch_baz()\n"; + return OK; +} + +1; + +__END__ + +here is a sample httpd.conf entry + + PerlModule Apache::Dispatch + PerlModule Foo + + <Location /Test> + SetHandler perl-script + PerlHandler Apache::Dispatch + DispatchPrefix Foo + DispatchExtras Pre Post Error + </Location> + +once you install it, you should be able to go to +http://localhost/Test/foo +or +http://localhost/Test/Bar/foo +etc, and get some results Added: trunk/t/lib/Apache/Foo.pm =================================================================== --- trunk/t/lib/Apache/Foo.pm (rev 0) +++ trunk/t/lib/Apache/Foo.pm 2006-04-23 06:01:28 UTC (rev 29) @@ -0,0 +1,64 @@ +package Apache::Foo; + +use Apache::Constants qw( OK SERVER_ERROR ); +use strict; + +sub dispatch_foo { + my $class = shift; + my $r = shift; + $r->send_http_header('text/plain'); + $r->print("Foo->dispatch_foo()"); + print STDERR "Foo->dispatch_foo()\n"; + return OK; +} + +sub dispatch_bar { + print STDERR "Foo->dispatch_bar()\n"; + return SERVER_ERROR; +} + +sub pre_dispatch { + print STDERR "Foo->pre_dispatch()\n"; +} + +sub post_dispatch { + print STDERR "Foo->post_dispatch()\n"; +} + +sub error_dispatch { + my $class = shift; + my $r = shift; + $r->send_http_header('text/plain'); + $r->print("Yikes! Foo->dispatch_error()"); + print STDERR "Yikes! Foo->dispatch_error()\n"; + return OK; +} + +sub dispatch_index { + my $class = shift; + my $r = shift; + $r->send_http_header('text/plain'); + $r->print("Foo->dispatch_index()"); + print STDERR "Foo->dispatch_index()\n"; + return OK; +} + +1; + +__END__ + +here is a sample httpd.conf entry + + PerlModule Apache::Dispatch + PerlModule Foo + + <Location /Test> + SetHandler perl-script + PerlHandler Apache::Dispatch + DispatchPrefix Foo + DispatchExtras Pre Post Error + </Location> + +once you install it, you should be able to go to +http://localhost/Test/foo +and get some results Property changes on: trunk/t/lib/Apache/Foo.pm ___________________________________________________________________ Name: svn:executable + * This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
