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;
  
  
  


Reply via email to