Hi all,
Below is an initial version of a patch against the latest CVS version of
RegistryCooker.pm (and RegistryLoader.pm) to support better subclassing,
including the ability to access module data from RegistryCooker in a
clean way and to add private data to subclasses, without relying on the
underlying array implementation (below my patch is the original message
written to the mod_perl list and Stas Bekman's response to provide the
context for this.)
The biggest part of this patch is from a change to the constants in
RegistryCooker to be _REQ instead of REQ, etc, because I couldn't have
two subs with the same name, and these constants are really internal
data anyway, especially if you want to be able to not rely on
RegistryCooker being implemented as an array. Let me know if this is a
problem, I can also do it the other way around (another possibility
would be to change them instead to something like REQ_IDX or something,
but its kinda wordy).
To use this in a subclass, I call "public" with this names of the
variables I want to use for my subclass, then use them like normal: eg:
public qw(
PAR_MEMBER
...
);
...
$self->PAR_MEMBER(<value>); # Set a value
...
$something = $self->PAR_MEMBER; #Get a value
We can also access the base class data in the same fashion:
my $r = $self->REQ;
I left the original constant usage inside RegistryCooker for performance
(no need to do an extra sub call inside RegistryCooker itself).
Please take a look at this and let me know what you think - I've tested
it under my configuration with the latest CVS and a now much nicer
looking version :-) of my Apache::PAR module as well as some simple
Registry scripts. If this patch is acceptable I'll also send another
patch to add the appropriate tests to the test suite and add a section
about subclassing RegistryCooker to the porting guidelines and
RegistryCooker docs.
Thanks,
--
Nathan Byrd <[EMAIL PROTECTED]>
~~~~~~~
--- RegistryCooker.pm Sun Feb 9 22:53:45 2003
+++ RegistryCooker.pm.new Sun Feb 9 22:56:10 2003
@@ -35,6 +35,94 @@
}
#########################################################################
+# code for automatic accessors/mutators
+#
+#########################################################################
+
+my $_self_offset = 0;
+
+#########################################################################
+# func: import
+# dflt: import
+# desc: Overrides default import to handle accessor creation
+# args: nothing
+# rtrn: nothing
+#########################################################################
+
+sub import
+{
+ no strict 'refs'; # turn off just for this sub
+ my $caller = (caller)[0];
+ *{"${caller}::public"} = \&public;
+ *{"${caller}::import"} = \&import;
+}
+
+
+#########################################################################
+# func: get_attr_offset
+# dflt: get_attr_offset
+# desc: returns the offset for a given package in the ISA tree
+# args: nothing
+# rtrn: number of attributes defined for this package
+# note: this function is recursive
+#########################################################################
+
+sub get_attr_offset
+{
+ no strict 'refs'; # turn off just for this sub
+ my $class = shift;
+ my $offset = 0;
+ foreach my $parent (@{"${class}::ISA"}) {
+ $offset += ${parent}->get_attr_offset()
if(${parent}->can('get_attr_offset'));
+ }
+ return $offset + $_self_offset;
+}
+
+#########################################################################
+# func: public
+# dflt: public
+# desc: creates accessor functions
+# args: list of accessors to create
+# rtrn: nothing
+# note: prototype defined so that public qw( ... ); can be used
+#########################################################################
+
+sub public(@)
+{
+ no strict 'refs'; # turn off just for this sub
+ my $class = (caller)[0];
+ my $parent_offset = ${class}->get_attr_offset;
+ for my $attr_name (@_)
+ {
+ if(!${class}->can($attr_name)) {
+ *{"${class}::${attr_name}"} = ${class}->make_accessor(
+ $_self_offset + $parent_offset);
+ $_self_offset++;
+ }
+ else { warn("$attr_name already defined"); }
+ }
+}
+
+#########################################################################
+# func: make_accessor
+# dflt: make_accessor
+# desc: does the work of creating an accessor
+# args: index to use for the accessor
+# rtrn: subroutine to be installed as accessor
+#########################################################################
+
+sub make_accessor
+{
+ my $index = $_[1];
+ return sub {
+ my $self = shift;
+ $self->[$index] = $_[0] if @_;
+ return $self->[$index];
+ }
+}
+
+
+#########################################################################
# debug constants
#
#########################################################################
@@ -58,14 +146,27 @@
# 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 _REQ => 0;
+use constant _FILENAME => 1;
+use constant _URI => 2;
+use constant _MTIME => 3;
+use constant _PACKAGE => 4;
+use constant _CODE => 5;
#########################################################################
+# base class accessors/mutators for access to data
+# note: should be in same order as above
+#
+#########################################################################
+public qw(
+ REQ
+ FILENAME
+ URI
+ MTIME
+ PACKAGE
+ CODE
+);
+#########################################################################
# OS specific constants
#
#########################################################################
@@ -108,15 +209,15 @@
#########################################################################
# func: init
# dflt: init
-# desc: initializes the data object's fields: REQ FILENAME URI
+# desc: initializes the data object's fields: _REQ _FILENAME _URI
# args: $r - Apache::Request object
# rtrn: nothing
#########################################################################
sub init {
- $_[0]->[REQ] = $_[1];
- $_[0]->[URI] = $_[1]->uri;
- $_[0]->[FILENAME] = $_[1]->filename;
+ $_[0]->[_REQ] = $_[1];
+ $_[0]->[_URI] = $_[1]->uri;
+ $_[0]->[_FILENAME] = $_[1]->filename;
}
#########################################################################
@@ -161,9 +262,9 @@
# handlers shouldn't set $r->status but return it, so we reset the
# status after running it
- my $old_status = $self->[REQ]->status;
+ my $old_status = $self->[_REQ]->status;
my $rc = $self->run;
- my $new_status = $self->[REQ]->status($old_status);
+ my $new_status = $self->[_REQ]->status($old_status);
return ($rc == Apache::OK && $old_status != $new_status)
? $new_status
: $rc;
@@ -180,8 +281,8 @@
sub run {
my $self = shift;
- my $r = $self->[REQ];
- my $package = $self->[PACKAGE];
+ my $r = $self->[_REQ];
+ my $package = $self->[_PACKAGE];
$self->set_script_name;
$self->chdir_file;
@@ -222,35 +323,35 @@
# desc: checks whether the script is allowed and can be compiled
# args: $self - registry blessed object
# rtrn: $rc - return status to forward
-# efct: initializes the data object's fields: MTIME
+# efct: initializes the data object's fields: _MTIME
#########################################################################
sub can_compile {
my $self = shift;
- my $r = $self->[REQ];
+ my $r = $self->[_REQ];
unless (-r $r->my_finfo && -s _) {
- $self->log_error("$self->[FILENAME] not found or unable to
stat");
+ $self->log_error("$self->[_FILENAME] not found or unable to
stat");
return Apache::NOT_FOUND;
}
return Apache::DECLINED if -d _;
- $self->[MTIME] = -M _;
+ $self->[_MTIME] = -M _;
unless (-x _ or IS_WIN32) {
$r->log_error("file permissions deny server execution",
- $self->[FILENAME]);
+ $self->[_FILENAME]);
return Apache::FORBIDDEN;
}
if (!($r->allow_options & Apache::OPT_EXECCGI)) {
$r->log_error("Options ExecCGI is off in this directory",
- $self->[FILENAME]);
+ $self->[_FILENAME]);
return Apache::FORBIDDEN;
}
- $self->debug("can compile $self->[FILENAME]") if DEBUG & D_NOISE;
+ $self->debug("can compile $self->[_FILENAME]") if DEBUG & D_NOISE;
return Apache::OK;
@@ -274,7 +375,7 @@
# desc: prepares the namespace
# args: $self - registry blessed object
# rtrn: the namespace
-# efct: initializes the field: PACKAGE
+# efct: initializes the field: _PACKAGE
#########################################################################
sub make_namespace {
@@ -291,7 +392,7 @@
# prepend root
$package = $self->namespace_root() . "::$package";
- $self->[PACKAGE] = $package;
+ $self->[_PACKAGE] = $package;
return $package;
}
@@ -311,7 +412,7 @@
my $self = shift;
my ($volume, $dirs, $file) =
- File::Spec::Functions::splitpath($self->[FILENAME]);
+ File::Spec::Functions::splitpath($self->[_FILENAME]);
my @dirs = File::Spec::Functions::splitdir($dirs);
return join '_', grep { defined && length } $volume, @dirs, $file;
}
@@ -320,14 +421,14 @@
sub namespace_from_uri {
my $self = shift;
- my $path_info = $self->[REQ]->path_info;
- my $script_name = $path_info && $self->[URI] =~ /$path_info$/ ?
- substr($self->[URI], 0, length($self->[URI]) - length($path_info)) :
- $self->[URI];
+ my $path_info = $self->[_REQ]->path_info;
+ my $script_name = $path_info && $self->[_URI] =~ /$path_info$/ ?
+ substr($self->[_URI], 0, length($self->[_URI]) - length($path_info)) :
+ $self->[_URI];
if ($ModPerl::RegistryCooker::NameWithVirtualHost &&
- $self->[REQ]->server->is_virtual) {
- my $name = $self->[REQ]->get_server_name;
+ $self->[_REQ]->server->is_virtual) {
+ my $name = $self->[_REQ]->get_server_name;
$script_name = join "", $name, $script_name if $name;
}
@@ -347,7 +448,7 @@
sub convert_script_to_compiled_handler {
my $self = shift;
- $self->debug("Adding package $self->[PACKAGE]") if DEBUG & D_NOISE;
+ $self->debug("Adding package $self->[_PACKAGE]") if DEBUG &
D_NOISE;
# get the script's source
$self->read_script;
@@ -359,8 +460,8 @@
# relative require/open will work.
$self->chdir_file;
-# undef &{"$self->[PACKAGE]\::handler"}; unless DEBUG & D_NOISE;
#avoid warnings
-# $self->[PACKAGE]->can('undef_functions') &&
$self->[PACKAGE]->undef_functions;
+# undef &{"$self->[_PACKAGE]\::handler"}; unless DEBUG & D_NOISE;
#avoid warnings
+# $self->[_PACKAGE]->can('undef_functions') &&
$self->[_PACKAGE]->undef_functions;
my $line = $self->get_mark_line;
@@ -368,15 +469,15 @@
my $eval = join '',
'package ',
- $self->[PACKAGE], ";",
+ $self->[_PACKAGE], ";",
"sub handler {\n",
$line,
- ${ $self->[CODE] },
+ ${ $self->[_CODE] },
"\n}"; # last line comment without newline?
my $rc = $self->compile(\$eval);
return $rc unless $rc == Apache::OK;
- $self->debug(qq{compiled package \"$self->[PACKAGE]\"}) if DEBUG &
D_NOISE;
+ $self->debug(qq{compiled package \"$self->[_PACKAGE]\"}) if DEBUG &
D_NOISE;
#$self->chdir_file("$Apache::Server::CWD/");
@@ -421,7 +522,7 @@
sub cache_it {
my $self = shift;
- $self->cache_table->{ $self->[PACKAGE] }{mtime} = $self->[MTIME];
+ $self->cache_table->{ $self->[_PACKAGE] }{mtime} = $self->[_MTIME];
}
@@ -436,7 +537,7 @@
sub is_cached {
my $self = shift;
- exists $self->cache_table->{ $self->[PACKAGE] }{mtime};
+ exists $self->cache_table->{ $self->[_PACKAGE] }{mtime};
}
@@ -456,9 +557,9 @@
# wasn't modified
sub should_compile_if_modified {
my $self = shift;
- $self->[MTIME] ||= -M $self->[REQ]->my_finfo;
+ $self->[_MTIME] ||= -M $self->[_REQ]->my_finfo;
!($self->is_cached &&
- $self->cache_table->{ $self->[PACKAGE] }{mtime} <=
$self->[MTIME]);
+ $self->cache_table->{ $self->[_PACKAGE] }{mtime} <=
$self->[_MTIME]);
}
# return false if the package is cached already
@@ -482,10 +583,10 @@
$self->debug("flushing namespace") if DEBUG & D_NOISE;
no strict 'refs';
- my $tab = \%{ $self->[PACKAGE] . '::' };
+ my $tab = \%{ $self->[_PACKAGE] . '::' };
for (keys %$tab) {
- my $fullname = join '::', $self->[PACKAGE], $_;
+ my $fullname = join '::', $self->[_PACKAGE], $_;
# code/hash/array/scalar might be imported make sure the gv
# does not point elsewhere before undefing each
if (%$fullname) {
@@ -527,15 +628,15 @@
# desc: reads the script in
# args: $self - registry blessed object
# rtrn: nothing
-# efct: initializes the CODE field with the source script
+# efct: initializes the _CODE field with the source script
#########################################################################
# reads the contents of the file
sub read_script {
my $self = shift;
- $self->debug("reading $self->[FILENAME]") if DEBUG & D_NOISE;
- $self->[CODE] = $self->[REQ]->my_slurp_filename;
+ $self->debug("reading $self->[_FILENAME]") if DEBUG & D_NOISE;
+ $self->[_CODE] = $self->[_REQ]->my_slurp_filename;
}
#########################################################################
@@ -545,7 +646,7 @@
# (defined in %switches) into a perl code.
# args: $self - registry blessed object
# rtrn: nothing
-# efct: the CODE field gets adjusted
+# efct: the _CODE field gets adjusted
#########################################################################
my %switches = (
@@ -560,7 +661,7 @@
sub rewrite_shebang {
my $self = shift;
- my($line) = ${ $self->[CODE] } =~ /^(.*)$/m;
+ my($line) = ${ $self->[_CODE] } =~ /^(.*)$/m;
my @cmdline = split /\s+/, $line;
return unless @cmdline;
return unless shift(@cmdline) =~ /^\#!/;
@@ -574,7 +675,7 @@
$prepend .= $switches{$_}->();
}
}
- ${ $self->[CODE] } =~ s/^/$prepend/ if $prepend;
+ ${ $self->[_CODE] } =~ s/^/$prepend/ if $prepend;
}
#########################################################################
@@ -586,7 +687,7 @@
#########################################################################
sub set_script_name {
- *0 = \(shift->[FILENAME]);
+ *0 = \(shift->[_FILENAME]);
}
#########################################################################
@@ -602,7 +703,7 @@
sub chdir_file_normal {
my($self, $dir) = @_;
- # $self->[REQ]->chdir_file($dir ? $dir : $self->[FILENAME]);
+ # $self->[_REQ]->chdir_file($dir ? $dir : $self->[_FILENAME]);
}
#########################################################################
@@ -615,19 +716,19 @@
sub get_mark_line {
my $self = shift;
- $ModPerl::Registry::MarkLine ? "\n#line 1 $self->[FILENAME]\n" :
"";
+ $ModPerl::Registry::MarkLine ? "\n#line 1 $self->[_FILENAME]\n" :
"";
}
#########################################################################
# func: strip_end_data_segment
# dflt: strip_end_data_segment
-# desc: remove the trailing non-code from $self->[CODE]
+# desc: remove the trailing non-code from $self->[_CODE]
# args: $self - registry blessed object
# rtrn: nothing
#########################################################################
sub strip_end_data_segment {
- ${ +shift->[CODE] } =~ s/__(END|DATA)__(.*)//s;
+ ${ +shift->[_CODE] } =~ s/__(END|DATA)__(.*)//s;
}
@@ -644,11 +745,11 @@
sub compile {
my($self, $eval) = @_;
- my $r = $self->[REQ];
+ my $r = $self->[_REQ];
- $self->debug("compiling $self->[FILENAME]") if DEBUG && D_COMPILE;
+ $self->debug("compiling $self->[_FILENAME]") if DEBUG && D_COMPILE;
- ModPerl::Global::special_list_clear(END => $self->[PACKAGE]);
+ ModPerl::Global::special_list_clear(END => $self->[_PACKAGE]);
ModPerl::Util::untaint($$eval);
{
@@ -707,16 +808,16 @@
sub debug {
my $self = shift;
my $class = ref $self;
- $self->[REQ]->log_error("$$: $class: " . join '', @_);
+ $self->[_REQ]->log_error("$$: $class: " . join '', @_);
}
sub log_error {
my($self, $msg) = @_;
my $class = ref $self;
- $self->[REQ]->log_error("$$: $class: $msg");
- $self->[REQ]->notes->set('error-notes' => $msg);
- $@{$self->[URI]} = $msg;
+ $self->[_REQ]->log_error("$$: $class: $msg");
+ $self->[_REQ]->notes->set('error-notes' => $msg);
+ $@{$self->[_URI]} = $msg;
}
#########################################################################
~~~~~~~~~~~~~~~~~
RegistryLoader.pm (small, but untested)
~~~~~~~~~~~~~~~~~
--- RegistryLoader.pm Sun Feb 9 23:33:17 2003
+++ RegistryLoader.pm.new Sun Feb 9 23:33:27 2003
@@ -104,7 +104,7 @@
# specified by the 'package' attribute, not RegistryLoader
sub namespace_root {
join '::', ModPerl::RegistryCooker::NAMESPACE_ROOT,
- shift->[ModPerl::RegistryCooker::REQ]->{package};
+ shift->[ModPerl::RegistryCooker::_REQ]->{package};
}
# override Apache class methods called by Modperl::Registry*. normally
On Mon, 2003-02-03 at 00:05, Stas Bekman wrote:
> Nathan Byrd wrote:
> > All,
> >
> > To begin with, should proposed mod_perl patches go to
> > [EMAIL PROTECTED]? The documentation seemed a little unclear in this
> > case (I decided to play it safe since I didn't run across any messages
> > on the dev list from outside developers.)
>
> [EMAIL PROTECTED] would be the right place. Also help with the doc would be
> *very* appreciated, I've started to write the initial doc, but it's a far away
> from being useful.
>
> > When I was converting Apache::PAR to work with mod_perl 2.x, one problem
> > I had was with the way in which ModPerl::RegistryCooker stores member
> > data. Any subclass of ModPerl::RegistryCooker (in my case, for
> > Apache::PAR::RegistryCooker) that need to store their own module data
> > have a problem - they need to pick an array element to store their data
> > in. Because of the way in which ModPerl::RegistryCooker works
> > currently, that means hardcoding an array index (because not all array
> > members are created in new or init). Thus, in
> > Apache::PAR::RegistryCooker I have a line similar to the following:
> >
> > use constant PARDATA => 8;
> >
> > This is not optimal, especially since this has already changed in the
> > CVS version of RegistryCooker since I started working on it - luckily,
> > to less members, not more :-)
> >
> > I propose a change to RegistryCooker.pm so that member data is always
> > defined in the init sub, so that I could change the above line to
> > something more like:
> >
> > use constant PARDATA => -1;
> >
> > and in my handler, push a new element on after new has been called.
> > This would keep future changes to the RegistryCooker script from
> > potentially breaking other modules which must store their own data as
> > well.
> >
> > Below is a (small) patch to the CVS version of RegistryCooker.pm to do
> > this. Down side is that if new member data is added, it would then also
> > need to be added to the init sub.
>
> If you want to extend the object itself, what we can do is to provide a class
> method which will return the current size of the object. I suggest a method,
> so sub-classes can be further sub-classable.
>
> package A;
> use constant SIZE => 5;
> sub object_size { SIZE }
>
> package B;
> use constant EXTRA_SIZE => 2;
> use base qw(A);
> sub object_size { SUPER::object_size + EXTRA_SIZE);
>
> package C;
> use constant EXTRA_SIZE => 2;
> use base qw(B);
> sub object_size { SUPER::object_size + EXTRA_SIZE);
>
> etc...
>
> of course here we cast in stone the implementation of the object as an ARRAY,
> which is not so cool.
>
> Alternatively we can provide a function to create accessor methods, which will
> transparently handle internal changes.
>
> We could also use the 'fields' pragma, but than we get married to the hash
> internals, though apparently an optimized compiled time one. We need it
> working for 5.6.1+, is it working fine with 5.6.1?
>
> Pseudohashes are certainly out of question.
>
> __________________________________________________________________
> Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
> http://stason.org/ mod_perl Guide ---> http://perl.apache.org
> mailto:[EMAIL PROTECTED] http://use.perl.org http://apacheweek.com
> http://modperlbook.org http://apache.org http://ticketmaster.com
--
Nathan Byrd <[EMAIL PROTECTED]>
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
