stas 2002/08/15 05:29:06
Modified: ModPerl-Registry/lib/ModPerl PerlRun.pm Registry.pm
RegistryCooker.pm
Log:
- replace the hardcoded cache and root namespaces with flexible methods
- get rid of the CLASS attribute and no strict 'refs'
- avoid starting the autogenerated package with __
- make the helper function uncache_myself use the cache_table() method
Revision Changes Path
1.3 +23 -21 modperl-2.0/ModPerl-Registry/lib/ModPerl/PerlRun.pm
Index: PerlRun.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/PerlRun.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- PerlRun.pm 14 Aug 2002 14:27:03 -0000 1.2
+++ PerlRun.pm 15 Aug 2002 12:29:06 -0000 1.3
@@ -23,27 +23,29 @@
# - 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',
- );
+ new => 'new',
+ init => 'init',
+ default_handler => 'default_handler',
+ run => 'run',
+ can_compile => 'can_compile',
+ make_namespace => 'make_namespace',
+ namespace_root => 'namespace_root_common',
+ namespace_from => 'namespace_from_filename',
+ is_cached => 'FALSE',
+ should_compile => 'TRUE',
+ flush_namespace => 'flush_namespace_normal',
+ cache_table => 'cache_table_common',
+ 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
1.4 +23 -21 modperl-2.0/ModPerl-Registry/lib/ModPerl/Registry.pm
Index: Registry.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/Registry.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- Registry.pm 14 Aug 2002 14:27:03 -0000 1.3
+++ Registry.pm 15 Aug 2002 12:29:06 -0000 1.4
@@ -22,27 +22,29 @@
# - 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',
- );
+ new => 'new',
+ init => 'init',
+ default_handler => 'default_handler',
+ run => 'run',
+ can_compile => 'can_compile',
+ make_namespace => 'make_namespace',
+ namespace_root => 'namespace_root_common',
+ namespace_from => 'namespace_from_filename',
+ is_cached => 'is_cached',
+ should_compile => 'should_compile_if_modified',
+ flush_namespace => 'NOP',
+ cache_table => 'cache_table_common',
+ 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
1.13 +95 -48 modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm
Index: RegistryCooker.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- RegistryCooker.pm 14 Aug 2002 14:38:07 -0000 1.12
+++ RegistryCooker.pm 15 Aug 2002 12:29:06 -0000 1.13
@@ -60,7 +60,6 @@
use constant PACKAGE => 4;
use constant CODE => 5;
use constant STATUS => 6;
-use constant CLASS => 7;
#########################################################################
# OS specific constants
@@ -96,13 +95,12 @@
#########################################################################
# func: init
# dflt: init
-# desc: initializes the data object's fields: CLASS REQ FILENAME URI
+# desc: initializes the data object's fields: 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;
@@ -205,7 +203,7 @@
my $r = $o->[REQ];
unless (-r $r->finfo && -s _) {
- xlog_error($r, "$$: $o->[FILENAME] not found or unable to stat");
+ $o->log_error("$o->[FILENAME] not found or unable to stat");
return Apache::NOT_FOUND;
}
@@ -230,6 +228,24 @@
return Apache::OK;
}
+#########################################################################
+# func: namespace_root
+# dflt: namespace_root_common
+# desc: define the namespace root for storing compiled scripts
+# args: $o - registry blessed object
+# rtrn: the namespace root
+#########################################################################
+
+*namespace_root = \&namespace_root_common;
+
+sub namespace_root_common {
+ 'ModPerl::RegistryROOT';
+}
+
+sub namespace_root_local {
+ my $o = shift;
+ join '::', ref($o), 'ROOT';
+}
#########################################################################
# func: make_namespace
@@ -249,10 +265,10 @@
$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";
+ $package =~ s/^(\d)/_$1/;
# prepend root
- $package = $o->[CLASS] . "::Cache::$package";
+ $package = $o->namespace_root() . "::$package";
$o->[PACKAGE] = $package;
@@ -276,7 +292,7 @@
my ($volume, $dirs, $file) =
File::Spec::Functions::splitpath($o->[FILENAME]);
my @dirs = File::Spec::Functions::splitdir($dirs);
- return join '_', ($volume||''), @dirs, $file;
+ return join '_', grep { defined && length } $volume, @dirs, $file;
}
# return a package name based on $r->uri only
@@ -356,48 +372,41 @@
}
#########################################################################
-# func: cache_it
-# dflt: cache_it
-# desc: mark the package as cached by storing its modification time
-# args: $o - registry blessed object
-# rtrn: nothing
+# func: cache_table
+# dflt: cache_table_common
+# desc: return a symbol table for caching compiled scripts in
+# args: $o - registry blessed object (or the class name)
+# rtrn: symbol table
#########################################################################
-sub cache_it {
+*cache_table = \&cache_table_common;
+
+sub cache_table_common {
+ \%ModPerl::RegistryCache;
+}
+
+
+sub cache_table_local {
my $o = shift;
+ my $class = ref($o) || $o;
no strict 'refs';
- ${ $o->[CLASS] }->{ $o->[PACKAGE] }{mtime} = $o->[MTIME];
+ \%$class;
}
#########################################################################
-# func: uncache_myself
-# dflt: uncache_myself
-# desc: unmark the package as cached by forgetting its modification time
-# args: none
+# func: cache_it
+# dflt: cache_it
+# desc: mark the package as cached by storing its modification time
+# args: $o - registry blessed object
# rtrn: nothing
-# note: this is a function and not a method, it should be called from
-# the registry script, and using the caller() method we figure
-# out the package the script was compiled into
-
#########################################################################
-sub uncache_myself {
- my $package = scalar caller;
- # guess the registry class from the first two package segments
- # XXX: this will break if someone creates a registry class which
- # is not X::Y, but this function was written for the tests.
- my($class) = $package =~ /([^:]+::[^:]+)/;
- warn "cannot figure out class name from $package",
- return unless defined $class;
- no strict 'refs';
- if (exists ${$class}->{$package} && exists ${$class}->{$package}{mtime}) {
- delete ${$class}->{$package}{mtime};
- }
- else {
- warn "cannot find ${class}->{$package}{mtime}";
- }
+sub cache_it {
+ my $o = shift;
+ $o->cache_table->{ $o->[PACKAGE] }{mtime} = $o->[MTIME];
}
+
#########################################################################
# func: is_cached
# dflt: is_cached
@@ -409,8 +418,7 @@
sub is_cached {
my $o = shift;
- no strict 'refs';
- exists ${$o->[CLASS]}->{ $o->[PACKAGE] }{mtime};
+ exists $o->cache_table->{ $o->[PACKAGE] }{mtime};
}
@@ -431,9 +439,8 @@
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]);
+ $o->cache_table->{ $o->[PACKAGE] }{mtime} <= $o->[MTIME]);
}
# return false if the package is cached already
@@ -591,7 +598,6 @@
sub get_mark_line {
my $o = shift;
- # META: shouldn't this be $o->[CLASS]?
$ModPerl::Registry::MarkLine ? "\n#line 1 $o->[FILENAME]\n" : "";
}
@@ -649,7 +655,7 @@
sub error_check {
my $o = shift;
if ($@ and substr($@,0,4) ne " at ") {
- xlog_error($o->[REQ], "$$: $o->[CLASS]: `$@'");
+ $o->log_error($@);
$@{$o->[REQ]->uri} = $@;
#$@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks
return Apache::SERVER_ERROR;
@@ -685,13 +691,54 @@
sub debug {
my $o = shift;
- $o->[REQ]->log_error("$$: $o->[CLASS]: " . join '', @_);
+ my $class = ref $o;
+ $o->[REQ]->log_error("$$: $class: " . join '', @_);
}
-sub xlog_error {
- my($r, $msg) = @_;
- $r->log_error($msg);
- $r->notes('error-notes', $msg);
+sub log_error {
+ my($o, $msg) = @_;
+ my $class = ref $o;
+
+ $o->[REQ]->log_error("$$: $class: $msg");
+ $o->[REQ]->notes('error-notes', $msg);
+}
+
+#########################################################################
+# func: uncache_myself
+# dflt: uncache_myself
+# desc: unmark the package as cached by forgetting its modification time
+# args: none
+# rtrn: nothing
+# note: this is a function and not a method, it should be called from
+# the registry script, and using the caller() method we figure
+# out the package the script was compiled into
+
+#########################################################################
+
+# this is a function should be called from the registry script, and
+# using the caller() method we figure out the package the script was
+# compiled into and trying to uncache it.
+#
+# it's currently used only for testing purposes and not a part of the
+# public interface. it expects to find the compiled package in the
+# symbol table cache returned by cache_table_common(), if you override
+# cache_table() to point to another function, this function will fail.
+sub uncache_myself {
+ my $package = scalar caller;
+ my($class) = __PACKAGE__->cache_table_common();
+
+ unless (defined $class) {
+ Apache->warn("$$: cannot figure out cache symbol table for $package");
+ return;
+ }
+
+ if (exists $class->{$package} && exists $class->{$package}{mtime}) {
+ Apache->warn("$$: uncaching $package\n") if DEBUG & D_COMPILE;
+ delete $class->{$package}{mtime};
+ }
+ else {
+ Apache->warn("$$: cannot find $package in cache");
+ }
}
1;
