stas 01/11/12 20:33:06
Modified: ModPerl-Registry/t/conf extra.conf.in
Added: ModPerl-Registry/t/conf modperl_extra_startup.pl
ModPerl-Registry/lib/ModPerl RegistryLoader.pm
Log:
- implement RegistryLoader and test it in the startup file
Revision Changes Path
1.3 +3 -0 modperl-2.0/ModPerl-Registry/t/conf/extra.conf.in
Index: extra.conf.in
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/conf/extra.conf.in,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- extra.conf.in 2001/10/19 06:46:25 1.2
+++ extra.conf.in 2001/11/13 04:33:06 1.3
@@ -3,6 +3,9 @@
# make sure that we test under Taint mode
PerlSwitches -T
+# run on startup
+PerlRequire @ServerRoot@/conf/modperl_extra_startup.pl
+
PerlSwitches -Mlib=@ServerRoot@/../lib
PerlSwitches -Mlib=@ServerRoot@/../../Apache-Test/lib
PerlSwitches -Mlib=@ServerRoot@/../../lib
1.1 modperl-2.0/ModPerl-Registry/t/conf/modperl_extra_startup.pl
Index: modperl_extra_startup.pl
===================================================================
#
use strict;
use warnings;
# test the scripts pre-loading by explicitly specifying uri => filename
use ModPerl::RegistryLoader ();
my $rl = ModPerl::RegistryLoader->new(package => "ModPerl::Registry");
my $base_dir = Apache::server_root_relative("cgi-bin");
my $base_uri = "/cgi-bin";
for my $file (qw(basic.pl env.pl)) {
my $file_path = "$base_dir/$file";
my $info_path = "$base_uri/$file";
$rl->handler($info_path, $file_path);
}
{
# test the scripts pre-loading by using trans sub
use ModPerl::RegistryLoader ();
use DirHandle ();
use strict;
my $dir = Apache::server_root_relative("cgi-bin");
sub trans {
my $uri = shift;
$uri =~ s|^/registry_bb/|cgi-bin/|;
return Apache::server_root_relative($uri);
}
my $rl = ModPerl::RegistryLoader->new(package => "ModPerl::RegistryBB",
trans => \&trans);
my $dh = DirHandle->new($dir) or die $!;
for my $file ($dh->read) {
next unless $file =~ /\.pl$/;
$rl->handler("/registry_bb/$file");
}
}
1;
1.1 modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryLoader.pm
Index: RegistryLoader.pm
===================================================================
package ModPerl::RegistryLoader;
use Apache::Const -compile => qw(OPT_EXECCGI);
use Carp;
our @ISA = ();
sub new {
my $class = shift;
my $self = bless {@_} => ref($class)||$class;
$self->load_package($self->{package});
return $self;
}
sub handler {
my($self, $uri, $filename) = @_;
# set the inheritance rules at run time
@ISA = $self->{package};
unless (defined $uri) {
$self->warn("uri is a required argument");
return;
}
if (defined $filename) {
unless (-e $filename) {
$self->warn("Cannot find: $filename");
return;
}
}
else {
# try to translate URI->filename
if (my $func = $self->{trans}) {
no strict 'refs';
$filename = $func->($uri);
unless (-e $filename) {
$self->warn("Cannot find a translated from uri: $filename");
return;
}
} else {
# try to guess
(my $guess = $uri) =~ s|^/||;
$filename = Apache::server_root_relative($guess);
$self->warn("Trying to guess filename based on uri");
unless (-e $filename) {
$self->warn("Cannot find guessed file: $filename",
"provide \$filename or 'trans' sub");
return;
}
}
}
if ($self->{debug}) {
$self->warn("*** uri=$uri, filename=$filename");
}
my $r = bless {
uri => $uri,
filename => $filename,
} => ref($self) || $self;
$r->SUPER::handler;
}
sub filename { shift->{filename} }
sub finfo { shift->{filename} }
sub uri { shift->{uri} }
sub path_info {}
sub allow_options { Apache::OPT_EXECCGI } #will be checked again at run-time
sub log_error { shift; die @_ if $@; warn @_; }
*log_reason = \&log_error;
sub run {} # don't run the script
sub server { shift }
# override Apache class methods called by Modperl::Registry*. normally
# only available at request-time via blessed request_rec pointer
sub slurp_filename {
my $r = shift;
my $filename = $r->filename;
open my $fh, $filename;
local $/;
my $code = <$fh>;
return \$code;
}
sub load_package {
my($self, $package) = @_;
croak "package to load wasn't specified" unless defined $package;
$package =~ s|::|/|g;
$package .= ".pm";
require $package;
};
sub warn {
my $self = shift;
Apache::warn(__PACKAGE__ . ": @_\n");
}
1;
__END__
