stas 01/10/09 05:47:38 Added: ModPerl-Registry MANIFEST Makefile.PL README TODO ModPerl-Registry/lib/ModPerl PerlRun.pm Registry.pm RegistryBB.pm RegistryCooker.pm RegistryNG.pm ModPerl-Registry/t .cvsignore TEST.PL basic.t closure.t ModPerl-Registry/t/cgi-bin basic.pl closure.pl env.pl local-conf.pl not_executable.pl require.pl ModPerl-Registry/t/conf .cvsignore extra.conf.in Log: - ModPerl::Registry and friends sub-project's basic functionality and tests Revision Changes Path 1.1 modperl-2.0/ModPerl-Registry/MANIFEST Index: MANIFEST =================================================================== MANIFEST This list of files Makefile.PL README TODO lib/ModPerl/PerlRun.pm lib/ModPerl/Registry.pm lib/ModPerl/RegistryBB.pm lib/ModPerl/RegistryCooker.pm lib/ModPerl/RegistryNG.pm t/TEST.PL t/basic.t t/closure.t t/cgi-bin/basic.pl t/cgi-bin/closure.pl t/cgi-bin/env.pl t/cgi-bin/local-conf.pl t/cgi-bin/not_executable.pl t/cgi-bin/require.pl t/conf/extra.conf.in t/htdocs/index.html 1.1 modperl-2.0/ModPerl-Registry/Makefile.PL Index: Makefile.PL =================================================================== require 5.6.1; use ExtUtils::MakeMaker; use lib qw(lib ../blib/lib); # enable 'make test|clean' use Apache::TestMM qw(test clean); # prerequisites my %require = ( "Apache::Test" => "", # any version will do? ); my @scripts = qw(t/TEST); # accept the configs from comman line Apache::TestMM::filter_args(); Apache::TestMM::generate_script('t/TEST'); WriteMakefile ( NAME => 'ModPerl::Registry', VERSION_FROM => 'lib/ModPerl/RegistryCooker.pm', PREREQ_PM => \%require, clean => { FILES => "@{ clean_files() }", }, ); sub clean_files { return [@scripts]; } 1.1 modperl-2.0/ModPerl-Registry/README Index: README =================================================================== to be written 1.1 modperl-2.0/ModPerl-Registry/TODO Index: TODO =================================================================== - META tags in the modules --------------- - print STDERR is buffered in test handlers, whereas warn() works normally. select() helps, but STDERR should be unbuffered in first place. --------------- > what's the replacement of NameWithVirtualHost? Obviously we need something > to distinguish between vhs. DougM: well, if possible we should distinguish between the uri and requested resource instead. in otherwords, we have the: r->uri => r->filename translation, just need to figure out if r->filename is the actual filename or a symlink (readlink can be used to get the real filename). then create a package based on the filename, but with as few package:: levels as possible (hopefully none beyond ModPerl::RegistryROOT::filename) DougM: using filenames makes for long packages names == lengthy lookups and more memory than we need. at least the way it is currently implemented where each '/' turns into '::'. could be that s,/,_,g is good enough, but haven't thought about this for a while. in any case, we should get rid of the NameWithVirtualHost stuff, its caused too many problems in the past. --------------- Bjarni R. Einarsson <[EMAIL PROTECTED]> has suggested this Registry hack http://marc.theaimsgroup.com/?l=apache-modperl-dev&m=98961929702745&w=2 Message-ID: <[EMAIL PROTECTED]> --------------- 1.1 modperl-2.0/ModPerl-Registry/lib/ModPerl/PerlRun.pm Index: PerlRun.pm =================================================================== package ModPerl::PerlRun; use strict; use warnings FATAL => 'all'; # we try to develop so we reload ourselves without die'ing on the warning no warnings qw(redefine); # XXX, this should go away in production! our $VERSION = '1.99'; use ModPerl::RegistryCooker; @ModPerl::PerlRun::ISA = qw(ModPerl::RegistryCooker); # META: prototyping ($$) segfaults on request sub handler { my $class = (@_ >= 2) ? shift : __PACKAGE__; my $r = shift; return $class->new($r)->default_handler(); } my $parent = 'ModPerl::RegistryCooker'; # the following code: # - specifies package's behavior different from default of $parent class # - speeds things up by shortcutting @ISA search, so even if the # default is used we still use the alias my %aliases = ( new => 'new', init => 'init', default_handler => 'default_handler', run => 'run', can_compile => 'can_compile', make_namespace => 'make_namespace', namespace_from => 'namespace_from_filename', is_cached => 'FALSE', should_compile => 'TRUE', flush_namespace => 'flush_namespace_normal', cache_it => 'NOP', read_script => 'read_script', rewrite_shebang => 'rewrite_shebang', set_script_name => 'set_script_name', chdir_file => 'chdir_file_normal', get_mark_line => 'get_mark_line', compile => 'compile', error_check => 'error_check', strip_end_data_segment => 'strip_end_data_segment', convert_script_to_compiled_handler => 'convert_script_to_compiled_handler', ); # in this module, all the methods are inherited from the same parent # class, so we fixup aliases instead of using the source package in # first place. $aliases{$_} = $parent . "::" . $aliases{$_} for keys %aliases; __PACKAGE__->install_aliases(\%aliases); 1; __END__ =head1 NAME ModPerl::PerlRun - =head1 SYNOPSIS =head1 DESCRIPTION =cut 1.1 modperl-2.0/ModPerl-Registry/lib/ModPerl/Registry.pm Index: Registry.pm =================================================================== package ModPerl::Registry; use strict; use warnings FATAL => 'all'; # we try to develop so we reload ourselves without die'ing on the warning no warnings qw(redefine); # XXX, this should go away in production! our $VERSION = '1.99'; use ModPerl::RegistryCooker; @ModPerl::Registry::ISA = qw(ModPerl::RegistryCooker); sub handler { my $class = (@_ >= 2) ? shift : __PACKAGE__; my $r = shift; return $class->new($r)->default_handler(); } my $parent = 'ModPerl::RegistryCooker'; # the following code: # - specifies package's behavior different from default of $parent class # - speeds things up by shortcutting @ISA search, so even if the # default is used we still use the alias my %aliases = ( new => 'new', init => 'init', default_handler => 'default_handler', run => 'run', can_compile => 'can_compile', make_namespace => 'make_namespace', namespace_from => 'namespace_from_filename', is_cached => 'is_cached', should_compile => 'should_compile_if_modified', flush_namespace => 'NOP', cache_it => 'cache_it', read_script => 'read_script', rewrite_shebang => 'rewrite_shebang', set_script_name => 'set_script_name', chdir_file => 'chdir_file_normal', get_mark_line => 'get_mark_line', compile => 'compile', error_check => 'error_check', strip_end_data_segment => 'strip_end_data_segment', convert_script_to_compiled_handler => 'convert_script_to_compiled_handler', ); # in this module, all the methods are inherited from the same parent # class, so we fixup aliases instead of using the source package in # first place. $aliases{$_} = $parent . "::" . $aliases{$_} for keys %aliases; __PACKAGE__->install_aliases(\%aliases); # Note that you don't have to do the aliases if you use defaults, it # just speeds things up the first time the sub runs, after that # methods are cached. # # But it's still handy, since you explicitly specify which subs from # the parent package you are using # # META: if the ISA search results are cached on the first lookup, may # be need to alias only the those that aren't the defaults? 1; __END__ =head1 NAME ModPerl::Registry - =head1 SYNOPSIS =head1 DESCRIPTION =cut 1.1 modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryBB.pm Index: RegistryBB.pm =================================================================== package ModPerl::RegistryBB; use strict; use warnings FATAL => 'all'; # we try to develop so we reload ourselves without die'ing on the warning no warnings qw(redefine); # XXX, this should go away in production! our $VERSION = '1.99'; use ModPerl::RegistryCooker; @ModPerl::RegistryBB::ISA = qw(ModPerl::RegistryCooker); # META: prototyping ($$) segfaults on request sub handler { my $class = (@_ >= 2) ? shift : __PACKAGE__; my $r = shift; return $class->new($r)->default_handler(); } # currently all the methods are inherited through the normal ISA # search may 1; __END__ =head1 NAME ModPerl::RegistryBB - =head1 SYNOPSIS =head1 DESCRIPTION C<ModPerl::RegistryBB> uses all the defaults, which do the very minimum to compile the file once and run it many times. =cut 1.1 modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm Index: RegistryCooker.pm =================================================================== # VERY IMPORTANT: Be very careful modifying the defaults, since many # VERY IMPORTANT: packages rely on them. In fact you should never # VERY IMPORTANT: modify the defaults after the package gets released, # VERY IMPORTANT: since they are a hardcoded part of this suite's API. package ModPerl::RegistryCooker; require 5.006; use strict; use warnings FATAL => 'all'; # we try to develop so we reload ourselves without die'ing on the warning no warnings qw(redefine); # XXX, this should go away in production! our $VERSION = '1.99'; use Apache::compat (); # Should not use Apache::compat, the following methods need to be implemented # $r->slurp_filename # $r->clear_rgy_endav # $r->stash_rgy_endav use Apache::Response; use Apache::Log; use Apache::Const -compile => qw(:common &OPT_EXECCGI); use File::Spec::Functions (); use ModPerl::Util (); ######################################################################### # issues # ######################################################################### # META: who sets this? What's the default? unless (defined $ModPerl::Registry::MarkLine) { $ModPerl::Registry::MarkLine = 1; } ### Optimizations # # - $o->[CLASS] of the subclass is known at compile time, so should # create the subs using $o->[CLASS] on the fly for each subclass # which wants them ### TODO # # - who handles END/BEGIN/,CHECK,INIT) blocks? # - see META's accross the file ######################################################################### # debug flag constants # ######################################################################### use constant D_ERROR => 1; use constant D_WARN => 2; use constant D_COMPILE => 4; use constant D_NOISE => 8; # use ModPerl::RegistryCooker::DEBUG constant if defined elsewhere # before the compilation of this package: D_NOISE devel mode (prod==0) #use constant DEBUG => ModPerl::RegistryCooker->can('DEBUG') || D_NOISE; #use Apache::ServerUtil; #use constant DEBUG => defined Apache->server->dir_config('ModPerl::RegistryCooker::DEBUG') ? Apache->server->dir_config('ModPerl::RegistryCooker::DEBUG') : D_NOISE; use constant DEBUG => D_NOISE; ######################################################################### # object's array index's access constants # ######################################################################### use constant REQ => 0; use constant FILENAME => 1; use constant URI => 2; use constant MTIME => 3; use constant PACKAGE => 4; use constant CODE => 5; use constant STATUS => 6; use constant CLASS => 7; ######################################################################### # OS specific constants # ######################################################################### use constant IS_WIN32 => $^O eq "MSWin32"; ######################################################################### # constant subs # ######################################################################### use constant NOP => sub { }; use constant TRUE => sub { 1 }; use constant FALSE => sub { 0 }; ######################################################################### # install the aliases into $class # ######################################################################### sub install_aliases { my ($class, $rh_aliases) = @_; no strict 'refs'; while (my($k,$v) = each %$rh_aliases) { if (my $sub = *{$v}{CODE}){ #warn "$class: ok: $k => $v"; *{ $class . "::$k" } = $sub; } else { die "$class: $k aliasing failed; sub $v doesn't exist"; } } } ######################################################################### # func: new # dflt: new # args: $class - class to bless into # $r - Apache::Request object # desc: create the class's object and bless it # rtrn: the newly created object ######################################################################### sub new { my($class, $r) = @_; my $o = bless [], $class; $o->init($r); #$o->debug("$$: init class: $class"); return $o; } ######################################################################### # func: init # dflt: init # desc: initializes the data object's fields: CLASS REQ FILENAME URI # args: $r - Apache::Request object # rtrn: nothing ######################################################################### sub init { $_[0]->[CLASS] = ref $_[0]; $_[0]->[REQ] = $_[1]; $_[0]->[URI] = $_[1]->uri; $_[0]->[FILENAME] = $_[1]->filename; } ######################################################################### # func: handler # dflt: handler # desc: the handler() sub that is expected by Apache # args: $class - handler's class # $r - Apache::Request object # (o)can be called as handler($r) as well (without leading $class) # rtrn: handler's response status # note: must be implemented in a sub-class unless configured as # Apache::Foo->handler in httpd.conf (because of the # __PACKAGE__, which is tied to the file) ######################################################################### # META: prototyping ($$) segfaults on request sub handler { my $class = (@_ >= 2) ? shift : __PACKAGE__; my $r = shift; $class->new($r)->default_handler(); } ######################################################################### # func: default_handler # dflt: META: see above # desc: META: see above # args: $o - registry blessed object # rtrn: handler's response status # note: that's what most sub-class handlers will call ######################################################################### sub default_handler { my $o = shift; $o->make_namespace; if ($o->should_compile) { my $rc = $o->can_compile; return $rc unless $rc == Apache::OK; $o->convert_script_to_compiled_handler; } return $o->run; } ######################################################################### # func: run # dflt: run # desc: executes the compiled code # args: $o - registry blessed object # rtrn: execution status (Apache::?) ######################################################################### sub run { my $o = shift; my $r = $o->[REQ]; my $package = $o->[PACKAGE]; $o->set_script_name; $o->chdir_file; my $rc = Apache::OK; my $cv = \&{"$package\::handler"}; { # run the code, preserve warnings setup when it's done no warnings; eval { $rc = &{$cv}($r, @_) } if $r->seqno; $o->[STATUS] = $rc; } $o->flush_namespace; # META: handle! #$o->chdir_file("$Apache::Server::CWD/"); if ( ($rc = $o->error_check) != Apache::OK) { return $rc; } return Apache::OK; } ######################################################################### # func: can_compile # dflt: can_compile # desc: checks whether the script is allowed and can be compiled # args: $o - registry blessed object # rtrn: $rc - return status to forward # efct: initializes the data object's fields: MTIME ######################################################################### sub can_compile { my $o = shift; my $r = $o->[REQ]; unless (-r $r->finfo && -s _) { $r->log_error("$$: $o->[FILENAME] not found or unable to stat"); return Apache::NOT_FOUND; } return Apache::DECLINED if -d _; $o->[MTIME] = -M _; unless (-x _ or IS_WIN32) { $r->log_reason("file permissions deny server execution", $o->[FILENAME]); return Apache::FORBIDDEN; } if (!($r->allow_options & Apache::OPT_EXECCGI)) { $r->log_reason("Options ExecCGI is off in this directory", $o->[FILENAME]); return Apache::FORBIDDEN; } $o->debug("can compile $o->[FILENAME]") if DEBUG & D_NOISE; return Apache::OK; } ######################################################################### # func: make_namespace # dflt: make_namespace # desc: prepares the namespace # args: $o - registry blessed object # rtrn: the namespace # efct: initializes the field: PACKAGE ######################################################################### sub make_namespace { my $o = shift; my $package = $o->namespace_from; # Escape everything into valid perl identifiers $package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg; # make sure that the sub-package doesn't start with a digit $package = "_$package"; # META: ??? explain $ModPerl::Registry::curstash = $package; # prepend root $package = $o->[CLASS] . "::Cache::$package"; $o->[PACKAGE] = $package; return $package; } ######################################################################### # func: namespace_from # dflt: namespace_from_filename # desc: returns a partial raw package name based on filename, uri, else # args: $o - registry blessed object # rtrn: a unique string ######################################################################### *namespace_from = \&namespace_from_filename; # return a package name based on $r->filename only sub namespace_from_filename { my $o = shift; my ($volume, $dirs, $file) = File::Spec::Functions::splitpath($o->[FILENAME]); my @dirs = File::Spec::Functions::splitdir($dirs); return join '_', ($volume||''), @dirs, $file; } # return a package name based on $r->uri only sub namespace_from_uri { my $o = shift; my $path_info = $o->[REQ]->path_info; my $script_name = $path_info && $o->[URI] =~ /$path_info$/ ? substr($o->[URI], 0, length($o->[URI]) - length($path_info)) : $o->[URI]; # META: do we handle this? # if ($ModPerl::Registry::NameWithVirtualHost && $o->[REQ]->server->is_virtual) { # my $name = $o->[REQ]->get_server_name; # $script_name = join "", $name, $script_name if $name; # } $script_name =~ s:/+$:/__INDEX__:; return $script_name; } ######################################################################### # func: convert_script_to_compiled_handler # dflt: convert_script_to_compiled_handler # desc: reads the script, converts into a handler and compiles it # args: $o - registry blessed object # rtrn: success/failure status ######################################################################### sub convert_script_to_compiled_handler { my $o = shift; $o->debug("Adding package $o->[PACKAGE]") if DEBUG & D_NOISE; # get the script's source $o->read_script; # convert the shebang line opts into perl code $o->rewrite_shebang; # mod_cgi compat, should compile the code while in its dir, so # relative require/open will work. $o->chdir_file; # META: what's this? # # compile this subroutine into the uniq package name # $o->debug("handler eval-ing") if DEBUG & D_NOISE; # undef &{"$o->[PACKAGE]\::handler"};# unless $Debug && $Debug & 4; #avoid warnings # $o->[PACKAGE]->can('undef_functions') && $o->[PACKAGE]->undef_functions; my $line = $o->get_mark_line; $o->strip_end_data_segment; my $eval = join '', 'package ', $o->[PACKAGE], ";", "sub handler {\n", $line, ${ $o->[CODE] }, "\n}"; # last line comment without newline? my %orig_inc = %INC; #warn "[-- $eval --]"; my $rc = $o->compile(\$eval); $o->debug(qq{compiled package \"$o->[PACKAGE]\"}) if DEBUG & D_NOISE; # META: handle! #$o->chdir_file("$Apache::Server::CWD/"); # %INC cleanup #in case .pl files do not declare package ...; for (keys %INC) { next if $orig_inc{$_}; next if /\.pm$/; delete $INC{$_}; } # META: $r->child_terminate is not implemented # if(my $opt = $r->dir_config("PerlRunOnce")) { # $r->child_terminate if lc($opt) eq "on"; # } $o->cache_it; return $rc; } ######################################################################### # func: cache_it # dflt: cache_it # desc: mark the package as cached by storing its modification time # args: $o - registry blessed object # rtrn: nothing ######################################################################### sub cache_it { my $o = shift; no strict 'refs'; ${$o->[CLASS]}->{ $o->[PACKAGE] }{mtime} = $o->[MTIME]; } ######################################################################### # func: is_cached # dflt: is_cached # desc: checks whether the package is already cached # args: $o - registry blessed object # rtrn: TRUE if cached, # FALSE otherwise ######################################################################### sub is_cached { my $o = shift; no strict 'refs'; exists ${$o->[CLASS]}->{ $o->[PACKAGE] }{mtime}; } ######################################################################### # func: should_compile # dflt: should_compile_once # desc: decide whether code should be compiled or not # args: $o - registry blessed object # rtrn: TRUE if should compile # FALSE otherwise # efct: sets MTIME if it's not set yet ######################################################################### *should_compile = \&should_compile_once; # return false only if the package is cached and its source file # wasn't modified sub should_compile_if_modified { my $o = shift; $o->[MTIME] ||= -M $o->[REQ]->finfo; no strict 'refs'; !($o->is_cached && ${$o->[CLASS]}->{ $o->[PACKAGE] }{mtime} <= $o->[MTIME]); } # return false if the package is cached already sub should_compile_once { not shift->is_cached; } ######################################################################### # func: flush_namespace # dflt: NOP (don't flush) # desc: flush the compiled package's namespace # args: $o - registry blessed object # rtrn: nothing ######################################################################### *flush_namespace = \&NOP; sub flush_namespace_normal { my $o = shift; $o->debug("flushing namespace") if DEBUG & D_NOISE; no strict 'refs'; my $tab = \%{ $o->[PACKAGE] . '::' }; for (keys %$tab) { my $fullname = join '::', $o->[PACKAGE], $_; #code/hash/array/scalar might be imported #make sure the gv does not point elsewhere #before undefing each if (%$fullname) { *{$fullname} = {}; undef %$fullname; } if (@$fullname) { *{$fullname} = []; undef @$fullname; } if ($$fullname) { my $tmp; #argh, no such thing as an anonymous scalar *{$fullname} = \$tmp; undef $$fullname; } if (defined &$fullname) { no warnings; local $^W = 0; if (my $p = prototype $fullname) { *{$fullname} = eval "sub ($p) {}"; } else { *{$fullname} = sub {}; } undef &$fullname; } if (*{$fullname}{IO}) { if (fileno $fullname) { close $fullname; } } } } ######################################################################### # func: read_script # dflt: read_script # desc: reads the script in # args: $o - registry blessed object # rtrn: nothing # efct: initializes the CODE field with the source script ######################################################################### # reads the contents of the file sub read_script { my $o = shift; $o->debug("reading $o->[FILENAME]") if DEBUG & D_NOISE; $o->[CODE] = $o->[REQ]->slurp_filename; } ######################################################################### # func: rewrite_shebang # dflt: rewrite_shebang # desc: parse the shebang line and convert command line switches # (defined in %switches) into a perl code. # args: $o - registry blessed object # rtrn: nothing # efct: the CODE field gets adjusted ######################################################################### my %switches = ( 'T' => sub { Apache::warn("T switch ignored, ". "enable with 'PerlTaintCheck On'\n") unless $Apache::__T; ""; }, 'w' => sub { "use warnings;\n" }, ); sub rewrite_shebang { my $o = shift; my($line) = ${ $o->[CODE] } =~ /^(.*)$/m; my @cmdline = split /\s+/, $line; return unless @cmdline; return unless shift(@cmdline) =~ /^\#!/; my $prepend = ""; for my $s (@cmdline) { next unless $s =~ s/^-//; last if substr($s,0,1) eq "-"; for (split //, $s) { next unless exists $switches{$_}; #print STDERR "parsed `$_' switch\n"; $prepend .= &{$switches{$_}}; } } ${ $o->[CODE] } =~ s/^/$prepend/ if $prepend; } ######################################################################### # func: set_script_name # dflt: set_script_name # desc: set $0 to the script's name # args: $o - registry blessed object # rtrn: nothing ######################################################################### sub set_script_name { *0 = \(shift->[FILENAME]); } ######################################################################### # func: chdir_file # dflt: NOP # desc: chdirs into $dir # args: $o - registry blessed object # $dir - a dir # rtrn: nothing (?or success/failure?) ######################################################################### *chdir_file = \&NOP; sub chdir_file_normal { my($o, $dir) = @_; # META: not implemented # META: see todo/api.txt unsafe! # $o->[REQ]->chdir_file($dir ? $dir : $o->[FILENAME]); } ######################################################################### # func: get_mark_line # dflt: get_mark_line # desc: generates the perl compiler #line directive # args: $o - registry blessed object # rtrn: returns the perl compiler #line directive ######################################################################### sub get_mark_line { my $o = shift; # META: shouldn't this be $o->[CLASS]? $ModPerl::Registry::MarkLine ? "\n#line 1 $o->[FILENAME]\n" : ""; } ######################################################################### # func: strip_end_data_segment # dflt: strip_end_data_segment # desc: remove the trailing non-code from $o->[CODE] # args: $o - registry blessed object # rtrn: nothing ######################################################################### sub strip_end_data_segment { ${ +shift->[CODE] } =~ s/__(END|DATA)__(.*)//s; } ######################################################################### # func: compile # dflt: compile # desc: compile the code in $eval # args: $o - registry blessed object # $eval - a ref to a scalar with the code to compile # rtrn: success/failure ######################################################################### sub compile { my($o, $eval) = @_; my $r = $o->[REQ]; $o->debug("compiling $o->[FILENAME]") if DEBUG && D_COMPILE; $r->clear_rgy_endav; ModPerl::Util::untaint($$eval); { # let the code define its own warn and strict level no strict; no warnings FATAL => 'all'; # because we use FATAL eval $$eval; } $r->stash_rgy_endav; return $o->error_check; } ######################################################################### # func: error_check # dflt: error_check # desc: checks $@ for errors # args: $o - registry blessed object # rtrn: Apache::SERVER_ERROR if $@ is set, Apache::OK otherwise ######################################################################### sub error_check { my $o = shift; if ($@ and substr($@,0,4) ne " at ") { $o->[REQ]->log_error("$$: $o->[CLASS]: `$@'"); $@{$o->[REQ]->uri} = $@; $@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks return Apache::SERVER_ERROR; } return Apache::OK; } ### helper methods sub debug{ my $o = shift; $o->[REQ]->log_error("$$: $o->[CLASS]: " . join '', @_); } 1; __END__ =head1 NAME ModPerl::RegistryCooker - =head1 SYNOPSIS =head1 DESCRIPTION =cut 1.1 modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryNG.pm Index: RegistryNG.pm =================================================================== package ModPerl::RegistryNG; # a back-compatibility placeholder *ModPerl::RegistryNG:: = \*ModPerl::Registry::; # META: prototyping ($$) segfaults on request sub handler { my $class = (@_ >= 2) ? shift : __PACKAGE__; my $r = shift; return $class->new($r)->default_handler(); } 1; __END__ =head1 NAME ModPerl::RegistryNG -- See ModPerl::Registry =head1 SYNOPSIS =head1 DESCRIPTION C<ModPerl::RegistryNG> is the same as C<ModPerl::Registry>. =cut 1.1 modperl-2.0/ModPerl-Registry/t/.cvsignore Index: .cvsignore =================================================================== logs htdocs 1.1 modperl-2.0/ModPerl-Registry/t/TEST.PL Index: TEST.PL =================================================================== #!perl use strict; use warnings FATAL => 'all'; # XXX: fixme #use lib map { "$_/Apache-Test/lib" } qw(. ..); #use lib map { "$_/blib/lib" } qw(. .. ../..); #use lib map { "$_/lib" } qw(. .. ../..); #use blib map { $_ } qw(. .. ../..); use lib map {("../blib/$_", "../../blib/$_")} qw(lib arch); #use blib qw(..); use Apache::TestRunPerl (); Apache::TestRunPerl->new->run(@ARGV); 1.1 modperl-2.0/ModPerl-Registry/t/basic.t Index: basic.t =================================================================== use strict; use warnings FATAL => 'all'; use ModPerl::Registry; use Apache::Test; use Apache::TestUtil; use Apache::TestRequest; my @modules = qw(registry registry_ng registry_bb perlrun); plan tests => scalar @modules * 3; my $cfg = Apache::Test::config(); # very basic compilation/response test for my $module (@modules) { my $url = "/$module/basic.pl"; ok t_cmp( "ok", $cfg->http_raw_get($url), "basic cgi test", ); } # test non-executable bit for my $module (@modules) { my $url = "/$module/not_executable.pl"; ok t_cmp( "403 Forbidden", HEAD($url)->status_line(), "non-executable file", ); } # test environment pre-set for my $module (@modules) { my $url = "/$module/env.pl?foo=bar"; ok t_cmp( "foo=bar", $cfg->http_raw_get($url), "mod_cgi-like environment pre-set", ); } # chdir is not safe yet! # # require (actually chdir test) #for my $module (@modules) { # my $url = "/$module/require.pl"; # ok t_cmp( # "it works", # $cfg->http_raw_get($url), # "mod_cgi-like environment pre-set", # ); #} 1.1 modperl-2.0/ModPerl-Registry/t/closure.t Index: closure.t =================================================================== use strict; use warnings FATAL => 'all'; use ModPerl::Registry; use Apache::Test; use File::Spec::Functions; use Apache::TestUtil; # this test tests how various registry packages cache and flush the # scripts their run, and whether they check modification on the disk # or not my @modules = qw(registry registry_ng registry_bb perlrun); plan tests => 6; my $cfg = Apache::Test::config(); my $file = 'closure.pl'; my $path = catfile $cfg->{vars}->{serverroot}, 'cgi-bin', $file; # for all sub-tests in this test, we assume that we always get onto # the same interpreter (since there are no other requests happening in # parallel { # ModPerl::PerlRun # always flush # no cache my $url = "/perlrun/$file"; # should be no closure effect, always returns 1 my $first = $cfg->http_raw_get($url); my $second = $cfg->http_raw_get($url); ok t_cmp( 0, $second - $first, "never a closure problem", ); # modify the file sleep_and_touch_file($path); # it doesn't matter, since the script is not cached anyway ok t_cmp( 1, $cfg->http_raw_get($url), "never a closure problem", ); } { # ModPerl::Registry # no flush # cache, but reload on modification my $url = "/registry/$file"; # we don't know what other test has called this uri before, so we # check the difference between two subsequent calls. In this case # the difference should be 1. my $first = $cfg->http_raw_get($url); my $second = $cfg->http_raw_get($url); ok t_cmp( 1, $second - $first, "closure problem should exist", ); # modify the file sleep_and_touch_file($path); # should no notice closure effect on first request ok t_cmp( 1, $cfg->http_raw_get($url), "no closure on the first request", ); } { # ModPerl::RegistryBB # no flush # cache once, don't check for mods my $url = "/registry_bb/$file"; # we don't know what other test has called this uri before, so we # check the difference between two subsequent calls. In this case # the difference should be 0. my $first = $cfg->http_raw_get($url); my $second = $cfg->http_raw_get($url); ok t_cmp( 1, $second - $first, "closure problem should exist", ); # modify the file sleep_and_touch_file($path); # my $third = $cfg->http_raw_get($url); ok t_cmp( 1, $third - $second, "no reload on mod, closure persist", ); } sub sleep_and_touch_file { my $file = shift; sleep 2; # so -M will be different, res: 1 sec, granularity > 1sec my $now = time; utime $now, $now, $file; } 1.1 modperl-2.0/ModPerl-Registry/t/cgi-bin/basic.pl Index: basic.pl =================================================================== #!perl -w # test all the basic functionality print "Content-type: text/plain\r\n\r\n"; print "ok"; __END__ this is some irrelevant data 1.1 modperl-2.0/ModPerl-Registry/t/cgi-bin/closure.pl Index: closure.pl =================================================================== #!perl -w # this script will suffer from a closure problem under registry # should see it under ::Registry # should not see it under ::PerlRun print "Content-type: text/plain\r\n\r\n"; # this is a closure (when compiled inside handler()): my $counter = 0; counter(); sub counter { #warn "$$"; print ++$counter; } 1.1 modperl-2.0/ModPerl-Registry/t/cgi-bin/env.pl Index: env.pl =================================================================== # test env vars print "Content-type: text/plain\r\n\r\n"; print exists $ENV{QUERY_STRING} && $ENV{QUERY_STRING}; __END__ 1.1 modperl-2.0/ModPerl-Registry/t/cgi-bin/local-conf.pl Index: local-conf.pl =================================================================== $test_require = 'it works'; 1; 1.1 modperl-2.0/ModPerl-Registry/t/cgi-bin/not_executable.pl Index: not_executable.pl =================================================================== #!perl -w # this test should return forbidden, since it should be not-executable print "Content-type: text/plain\r\n\r\n"; print "ok"; __END__ this is some irrelevant data 1.1 modperl-2.0/ModPerl-Registry/t/cgi-bin/require.pl Index: require.pl =================================================================== # test the require print "Content-type: text/plain\r\n\r\n"; use lib qw(.); my $file = "./local-conf.pl"; require $file; print defined $test_require && $test_require; 1.1 modperl-2.0/ModPerl-Registry/t/conf/.cvsignore Index: .cvsignore =================================================================== extra.conf httpd.conf apache_test_config.pm 1.1 modperl-2.0/ModPerl-Registry/t/conf/extra.conf.in Index: extra.conf.in =================================================================== #this file will be Include-d by @ServerRoot@/httpd.conf # make sure that we test under Taint mode PerlSwitches -T PerlSwitches -Mlib=@ServerRoot@/../lib PerlSwitches -Mlib=@ServerRoot@/../../lib PerlSwitches -Mlib=@ServerRoot@/../../blib/lib PerlSwitches -Mlib=@ServerRoot@/../../blib/arch Alias /registry/ @ServerRoot@/cgi-bin/ Alias /registry_ng/ @ServerRoot@/cgi-bin/ Alias /registry_bb/ @ServerRoot@/cgi-bin/ Alias /registry_oo_conf/ @ServerRoot@/cgi-bin/ Alias /perlrun/ @ServerRoot@/cgi-bin/ #PerlModule TestDebugMy PerlSetVar ModPerl::RegistryCooker::DEBUG 0 ### DEVMODE: Remove in production ### PerlModule Apache::Reload PerlInitHandler Apache::Reload PerlSetVar ReloadAll Off PerlSetVar ReloadModules "ModPerl::*" PerlModule ModPerl::RegistryCooker PerlModule ModPerl::Util PerlModule ModPerl::RegistryNG <Location /registry_ng> PerlOptions +GlobalRequest SetHandler perl-script Options +ExecCGI PerlResponseHandler ModPerl::RegistryNG PerlOptions +ParseHeaders </Location> PerlModule ModPerl::RegistryBB <Location /registry_bb> PerlOptions +GlobalRequest SetHandler perl-script Options +ExecCGI PerlResponseHandler ModPerl::RegistryBB PerlOptions +ParseHeaders </Location> PerlModule ModPerl::PerlRun <Location /perlrun> PerlOptions +GlobalRequest SetHandler perl-script Options +ExecCGI PerlResponseHandler ModPerl::PerlRun PerlOptions +ParseHeaders </Location> PerlModule ModPerl::Registry <Location /registry> PerlOptions +GlobalRequest SetHandler perl-script Options +ExecCGI PerlResponseHandler ModPerl::Registry PerlOptions +ParseHeaders </Location> # META: dumps core on OO handlers <Location /registry_oo_conf> PerlOptions +GlobalRequest SetHandler perl-script Options +ExecCGI PerlResponseHandler ModPerl::Registry->handler PerlOptions +ParseHeaders </Location>