here is some initial Apache-Registry subproject.
There are quite a few issues to resolve, but the basic things work. Need
to write the loader though.
If you want to look at the code look at Apache/RegistryCooker.pm first,
and then on any of (Registry(|BB|BG)|PerlRun).pm
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/lib/Apache/Registry.pm Mon Oct 8 16:59:55 2001
@@ -0,0 +1,84 @@
+package Apache::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!
+
+$Apache::Registry::VERSION = '1.99_01';
+
+use Apache::RegistryCooker;
+@Apache::Registry::ISA = qw(Apache::RegistryCooker);
+
+sub handler {
+ my $class = (@_ >= 2) ? shift : __PACKAGE__;
+ my $r = shift;
+ return $class->new($r)->default_handler();
+}
+
+my $parent = 'Apache::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
+
+Apache::Registry -
+
+=head1 SYNOPSIS
+
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/lib/Apache/PerlRun.pm Mon Oct 8 16:57:00 2001
@@ -0,0 +1,77 @@
+package Apache::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!
+
+$Apache::PerlRun::VERSION = '1.99_01';
+
+use Apache::RegistryCooker;
+@Apache::PerlRun::ISA = qw(Apache::RegistryCooker);
+
+# META: prototyping ($$) segfaults on request
+sub handler {
+ my $class = (@_ >= 2) ? shift : __PACKAGE__;
+ my $r = shift;
+ return $class->new($r)->default_handler();
+}
+
+my $parent = 'Apache::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
+
+Apache::PerlRun -
+
+=head1 SYNOPSIS
+
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/lib/Apache/RegistryLoader.pm Tue Oct 9 00:51:47 2001
@@ -0,0 +1,11 @@
+package Apache::RegistryLoader;
+
+# should think about a few loader packages where each package
+# corresponds to its run-time registry package
+
+# or should it be a single package that accepts the desired driver as
+# an argument?
+
+
+1;
+__END__
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/lib/Apache/RegistryNG.pm Mon Oct 8 16:57:00 2001
@@ -0,0 +1,27 @@
+package Apache::RegistryNG;
+
+# a back-compatibility placeholder
+*Apache::RegistryNG:: = \*Apache::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
+
+Apache::RegistryNG -- See Apache::Registry
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+C<Apache::RegistryNG> is the same as C<Apache::Registry>.
+
+=cut
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/lib/Apache/RegistryBB.pm Mon Oct 8 16:57:00 2001
@@ -0,0 +1,40 @@
+package Apache::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!
+
+$Apache::RegistryBB::VERSION = '1.99_01';
+
+use Apache::RegistryCooker;
+@Apache::RegistryBB::ISA = qw(Apache::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
+
+Apache::RegistryBB -
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+C<Apache::RegistryBB> uses all the defaults, which do the very minimum
+to compile the file once and run it many times.
+
+=cut
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/lib/Apache/RegistryCooker.pm Tue Oct 9 01:32:12 2001
@@ -0,0 +1,719 @@
+# 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 Apache::RegistryCooker;
+
+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!
+
+# META: do we need this? I think we 'require 5.6.0'
+#BEGIN {
+# if ($] < 5.006) {
+# $INC{'warnings.pm'} = __FILE__;
+# *warnings::unimport = sub {};
+# }
+#}
+
+$Apache::RegistryCooker::VERSION = '1.99';
+
+use Apache::compat ();
+# Should not use Apache::compat, the following methods need to be implemented
+# $r->slurp_filename
+# Apache->untaint
+# $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 ();
+
+#########################################################################
+# issues
+#
+#########################################################################
+
+# META: who sets this? What's the default?
+unless (defined $Apache::Registry::MarkLine) {
+ $Apache::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 Apache::RegistryCooker::DEBUG constant if defined elsewhere
+# before the compilation of this package: D_NOISE devel mode (prod==0)
+use constant DEBUG => Apache::RegistryCooker->can('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);
+ #$r->log_error("$$: 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;
+
+ my $errsv = "";
+ if ($@) {
+ $errsv = $@;
+ $@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks
+ $@{$r->uri} = $errsv;
+ }
+
+ # META: handle!
+ #$o->chdir_file("$Apache::Server::CWD/");
+
+ if ($errsv) {
+ $r->log_error($errsv);
+ return Apache::SERVER_ERROR;
+ }
+
+ return wantarray ? (Apache::OK, $rc) : 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];
+
+ $r->log_error("$$: $o->[CLASS] executing $o->[FILENAME]")
+ if DEBUG & D_NOISE;
+
+ 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;
+ }
+
+ 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
+ $Apache::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 ($Apache::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->[REQ]->log_error("$$: 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;
+
+# ???
+# # compile this subroutine into the uniq package name
+# $o->[REQ]->log_error("$$: Apache::Registry::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],
+ ';use Apache qw(exit);',
+ "sub handler {\n",
+ $line,
+ ${ $o->[CODE] },
+ "\n}"; # last line comment without newline?
+
+ my %orig_inc = %INC;
+
+#warn "[-- $eval --]";
+ my $rc = $o->compile(\$eval);
+ $o->[REQ]->log_error(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->[REQ]->log_error("$$: flushing namespace");
+
+ 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->[REQ]->log_error("$$: $o->[CLASS] 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]?
+ $Apache::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];
+
+ $r->log_error("$$: $o->[CLASS]::compile $o->[FILENAME]")
+ if DEBUG && D_COMPILE;
+
+ $r->clear_rgy_endav;
+ Apache->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;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Apache::RegistryCooker -
+
+=head1 SYNOPSIS
+
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/Makefile.PL Tue Oct 9 01:34:30 2001
@@ -0,0 +1,34 @@
+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 => 'Apache::Registry',
+ VERSION_FROM => 'lib/Apache/RegistryCooker.pm',
+ PREREQ_PM => \%require,
+ clean => {
+ FILES => "@{ clean_files() }",
+ },
+ );
+
+sub clean_files {
+ return [@scripts];
+}
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/MANIFEST Tue Oct 9 01:37:44 2001
@@ -0,0 +1,22 @@
+MANIFEST This list of files
+Makefile.PL
+README
+TODO
+lib/Apache/PerlRun.pm
+lib/Apache/Registry.pm
+lib/Apache/RegistryBB.pm
+lib/Apache/RegistryCooker.pm
+lib/Apache/RegistryLoader.pm
+lib/Apache/RegistryNG.pm
+lib/Apache/Reload.pm
+t/TEST.PL
+t/basic.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/closure.t
+t/conf/extra.conf.in
+t/htdocs/index.html
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/README Mon Oct 8 16:57:00 2001
@@ -0,0 +1 @@
+to be written
\ No newline at end of file
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/TODO Tue Oct 9 01:31:43 2001
@@ -0,0 +1,36 @@
+- 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
+Apache::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]>
+
+---------------
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/TEST Tue Oct 9 01:36:23 2001
@@ -0,0 +1,16 @@
+#!/home/stas/perl/ithread/bin/perl
+# WARNING: this file is generated, edit t/TEST.PL instead
+%Apache::TestConfig::Argv = qw(apxs /home/stas/httpd/prefork/bin/apxs);
+#!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 Apache::TestRunPerl ();
+
+Apache::TestRunPerl->new->run(@ARGV);
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/conf/.cvsignore Mon Oct 8 16:57:00 2001
@@ -0,0 +1,4 @@
+mime.types
+extra.conf
+httpd.conf
+apache_test_config.pm
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/conf/extra.conf.in Tue Oct 9 01:03:46 2001
@@ -0,0 +1,64 @@
+#this file will be Include-d by @ServerRoot@/httpd.conf
+
+Alias /registry_ng/ @ServerRoot@/cgi-bin/
+Alias /registry_bb/ @ServerRoot@/cgi-bin/
+Alias /registry/ @ServerRoot@/cgi-bin/
+Alias /registry_oo_conf/ @ServerRoot@/cgi-bin/
+Alias /perlrun/ @ServerRoot@/cgi-bin/
+
+PerlSwitches -Mlib=@ServerRoot@/../lib
+PerlSwitches -Mlib=@ServerRoot@/../../lib
+
+### DEVMODE: Remove in production ###
+PerlModule Apache::Reload
+PerlPostReadRequestHandler Apache::Reload
+PerlSetVar ReloadAll Off
+PerlSetVar ReloadModules "Apache::*"
+
+PerlModule Apache::RegistryCooker
+
+PerlModule Apache::RegistryNG
+<Location /registry_ng>
+ PerlOptions +GlobalRequest
+ SetHandler perl-script
+ Options +ExecCGI
+ PerlResponseHandler Apache::RegistryNG
+ PerlOptions +ParseHeaders
+</Location>
+
+PerlModule Apache::RegistryBB
+<Location /registry_bb>
+ PerlOptions +GlobalRequest
+ SetHandler perl-script
+ Options +ExecCGI
+ PerlResponseHandler Apache::RegistryBB
+ PerlOptions +ParseHeaders
+</Location>
+
+PerlModule Apache::PerlRun
+<Location /perlrun>
+ PerlOptions +GlobalRequest
+ SetHandler perl-script
+ Options +ExecCGI
+ PerlResponseHandler Apache::PerlRun
+ PerlOptions +ParseHeaders
+</Location>
+
+PerlModule Apache::Registry
+<Location /registry>
+ PerlOptions +GlobalRequest
+ SetHandler perl-script
+ Options +ExecCGI
+ PerlResponseHandler Apache::Registry
+ PerlOptions +ParseHeaders
+</Location>
+
+# META: dumps core on OO handlers
+<Location /registry_oo_conf>
+ PerlOptions +GlobalRequest
+ SetHandler perl-script
+ Options +ExecCGI
+ PerlResponseHandler Apache::Registry->handler
+ PerlOptions +ParseHeaders
+</Location>
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/.cvsignore Mon Oct 8 16:57:00 2001
@@ -0,0 +1,2 @@
+logs
+htdocs
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/basic.t Tue Oct 9 00:49:14 2001
@@ -0,0 +1,60 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::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",
+# );
+#}
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/TEST.PL Mon Oct 8 16:57:00 2001
@@ -0,0 +1,13 @@
+#!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 Apache::TestRunPerl ();
+
+Apache::TestRunPerl->new->run(@ARGV);
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/htdocs/index.html Mon Oct 8 16:57:00 2001
@@ -0,0 +1 @@
+welcome to localhost:8529
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/cgi-bin/closure.pl Tue Oct 9 01:35:30 2001
@@ -0,0 +1,17 @@
+#!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;
+}
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/cgi-bin/not_executable.pl Mon Oct 8 17:13:49 2001
@@ -0,0 +1,10 @@
+#!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
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/cgi-bin/basic.pl Mon Oct 8 17:11:05 2001
@@ -0,0 +1,10 @@
+#!perl -w
+
+# test all the basic functionality
+
+print "Content-type: text/plain\r\n\r\n";
+print "ok";
+
+__END__
+
+this is some irrelevant data
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/cgi-bin/env.pl Tue Oct 9 00:40:48 2001
@@ -0,0 +1,6 @@
+# test env vars
+
+print "Content-type: text/plain\r\n\r\n";
+print exists $ENV{QUERY_STRING} && $ENV{QUERY_STRING};
+
+__END__
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/cgi-bin/require.pl Tue Oct 9 00:47:28 2001
@@ -0,0 +1,9 @@
+# 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;
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/cgi-bin/local-conf.pl Tue Oct 9 00:48:47 2001
@@ -0,0 +1,3 @@
+$test_require = 'it works';
+
+1;
--- /dev/null Thu Jan 1 07:30:00 1970
+++ Apache-Registry/t/closure.t Tue Oct 9 00:26:27 2001
@@ -0,0 +1,125 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::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
+
+{
+ # Apache::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",
+ );
+
+}
+
+
+
+{
+ # Apache::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",
+ );
+
+}
+
+
+
+
+{
+ # Apache::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;
+}
_____________________________________________________________________
Stas Bekman JAm_pH -- Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide http://perl.apache.org/guide
mailto:[EMAIL PROTECTED] http://ticketmaster.com http://apacheweek.com
http://singlesheaven.com http://perl.apache.org http://perlmonth.com/
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
