Following this discussion: http://marc.theaimsgroup.com/?t=107100040400003&r=1&w=2
I've made a few adjustements and cleanups.
The following patch adds ModPerl::Util::file2package() to build a safe
package from a pathname or filename.
This is in turn used by <Perl> sections to put each block in it's own
namespace.
Configuration data placed in Apache::ReadConfig:: directly is processed
after the end of each <Perl> blocks to preserve current behaviour.
Should be marked as deprecated as soon as users can feed their own
configuration to Apache::PerlSections (not possible quite yet)
How about this?
Index: src/modules/perl/modperl_cmd.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.c,v
retrieving revision 1.51
diff -u -I$Id: -r1.51 modperl_cmd.c
--- src/modules/perl/modperl_cmd.c 17 Nov 2003 01:11:06 -0000 1.51
+++ src/modules/perl/modperl_cmd.c 11 Dec 2003 19:42:00 -0000
@@ -363,6 +363,7 @@
modperl_handler_t *handler = NULL;
const char *package_name = NULL;
const char *line_header = NULL;
+ const char *namespace = NULL;
int status = OK;
AV *args = Nullav;
SV *dollar_zero = Nullsv;
@@ -399,8 +400,16 @@
if (!(package_name = apr_table_get(options, "package"))) {
package_name = apr_pstrdup(p, MP_DEFAULT_PERLSECTION_PACKAGE);
- apr_table_set(options, "package", package_name);
}
+
+ namespace = modperl_file2package(p, parms->directive->filename);
+
+ package_name = apr_psprintf(p, "%s::%s::line_%d",
+ package_name,
+ namespace,
+ parms->directive->line_num);
+
+ apr_table_set(options, "package", package_name);
line_header = apr_psprintf(p, "\n#line %d %s\n",
parms->directive->line_num,
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.58
diff -u -I$Id: -r1.58 modperl_util.c
--- src/modules/perl/modperl_util.c 25 Nov 2003 20:31:29 -0000 1.58
+++ src/modules/perl/modperl_util.c 11 Dec 2003 19:42:00 -0000
@@ -769,3 +769,53 @@
}
}
#endif
+
+#define MP_VALID_PKG_CHAR(c) (isalnum(c) ||(c) == '_')
+#define MP_VALID_PATH_DELIM(c) ((c) == '/' || (c) =='\\')
+char *modperl_file2package(apr_pool_t *p, const char *file)
+{
+ char *package;
+ char *c;
+ const char *f;
+ int len = strlen(file)+1;
+
+ /* First, skip invalid prefix characters */
+ while (!MP_VALID_PKG_CHAR(*file)) {
+ file++;
+ len--;
+ }
+
+ /* Then figure out how big the package name will be like */
+ for(f = file; *f; f++) {
+ if (MP_VALID_PATH_DELIM(*f)) {
+ len++;
+ }
+ }
+
+ package = apr_pcalloc(p, len);
+
+ /* Then, replace bad characters with '_' */
+ for (c = package; *file; c++, file++) {
+ if (MP_VALID_PKG_CHAR(*file)) {
+ *c = *file;
+ }
+ else if (MP_VALID_PATH_DELIM(*file)) {
+
+ /* Eliminate subsequent duplicate path delim */
+ while (*(file+1) && MP_VALID_PATH_DELIM(*(file+1))) {
+ file++;
+ }
+
+ /* path delim not until end of line */
+ if (*(file+1)) {
+ *c = *(c+1) = ':';
+ c++;
+ }
+ }
+ else {
+ *c = '_';
+ }
+ }
+
+ return package;
+}
Index: src/modules/perl/modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.48
diff -u -I$Id: -r1.48 modperl_util.h
--- src/modules/perl/modperl_util.h 22 Sep 2003 23:46:19 -0000 1.48
+++ src/modules/perl/modperl_util.h 11 Dec 2003 19:42:00 -0000
@@ -159,4 +159,5 @@
void modperl_apr_table_dump(pTHX_ apr_table_t *table, char *name);
#endif
+char *modperl_file2package(apr_pool_t *p, const char *file);
#endif /* MODPERL_UTIL_H */
Index: lib/Apache/PerlSections.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/PerlSections.pm,v
retrieving revision 1.1
diff -u -I$Id: -r1.1 PerlSections.pm
--- lib/Apache/PerlSections.pm 20 Oct 2003 17:44:48 -0000 1.1
+++ lib/Apache/PerlSections.pm 11 Dec 2003 19:42:00 -0000
@@ -13,6 +13,7 @@
use Apache::Const -compile => qw(OK);
use constant SPECIAL_NAME => 'PerlConfig';
+use constant SPECIAL_PACKAGE => 'Apache::ReadConfig';
sub new {
my($package, @args) = @_;
@@ -54,24 +55,28 @@
sub symdump {
my($self) = @_;
- my $pack = $self->package;
-
unless ($self->{symbols}) {
- $self->{symbols} = [];
-
no strict;
-
- #XXX: Shamelessly borrowed from Devel::Symdump;
- while (my ($key, $val) = each(%{ *{"$pack\::"} })) {
- local (*ENTRY) = $val;
- if (defined $val && defined *ENTRY{SCALAR}) {
- push @{$self->{symbols}}, [$key, $ENTRY];
- }
- if (defined $val && defined *ENTRY{ARRAY}) {
- push @{$self->{symbols}}, [$key, [EMAIL PROTECTED];
- }
- if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) {
- push @{$self->{symbols}}, [$key, \%ENTRY];
+
+ $self->{symbols} = [];
+
+ #XXX: Here would be a good place to warn about NOT using
+ # Apache::ReadConfig:: directly in <Perl> sections
+ foreach my $pack ($self->package, $self->SPECIAL_PACKAGE) {
+ #XXX: Shamelessly borrowed from Devel::Symdump;
+ while (my ($key, $val) = each(%{ *{"$pack\::"} })) {
+ #We don't want to pick up stashes...
+ next if ($key =~ /::$/);
+ local (*ENTRY) = $val;
+ if (defined $val && defined *ENTRY{SCALAR}) {
+ push @{$self->{symbols}}, [$key, $ENTRY];
+ }
+ if (defined $val && defined *ENTRY{ARRAY}) {
+ push @{$self->{symbols}}, [$key, [EMAIL PROTECTED];
+ }
+ if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) {
+ push @{$self->{symbols}}, [$key, \%ENTRY];
+ }
}
}
}
Index: t/conf/extra.last.conf.in
===================================================================
RCS file: /home/cvs/modperl-2.0/t/conf/extra.last.conf.in,v
retrieving revision 1.9
diff -u -I$Id: -r1.9 extra.last.conf.in
--- t/conf/extra.last.conf.in 17 Nov 2003 01:11:06 -0000 1.9
+++ t/conf/extra.last.conf.in 11 Dec 2003 19:42:00 -0000
@@ -19,6 +19,7 @@
};
#This is a comment
$TestDirective::perl::comments="yes";
+$TestDirective::perl::PACKAGE = __PACKAGE__;
</Perl>
<Perl >
@@ -26,6 +27,23 @@
$TestDirective::perl::filename = __FILE__;
$TestDirective::perl::dollar_zero = $0;
$TestDirective::perl::line = __LINE__;
+</Perl>
+
+#Handle re-entrant <Perl> sections
+<Perl >
+$Include = "@ServerRoot@/conf/perlsection.conf";
+</Perl>
+
+#Deprecated access to Apache::ReadConfig:: still works
+<Perl >
+push @Apache::ReadConfig::Alias,
+ ['/perl_sections_readconfig', '@DocumentRoot@'];
+$Apache::ReadConfig::Location{'/perl_sections_readconfig'} = {
+ 'PerlInitHandler' => 'ModPerl::Test::add_config',
+ 'AuthType' => 'Basic',
+ 'AuthName' => 'PerlSection',
+ 'PerlAuthenHandler' => 'TestHooks::authen',
+ };
</Perl>
### --------------------------------- ###
Index: t/conf/perlsection.conf
===================================================================
RCS file: t/conf/perlsection.conf
diff -N t/conf/perlsection.conf
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ t/conf/perlsection.conf 11 Dec 2003 19:42:00 -0000
@@ -0,0 +1,4 @@
+#This is to test re-entrancy of <Perl> blocks
+<Perl >
+$TestDirective::perl::Included++;
+</Perl>
Index: t/directive/perl.t
===================================================================
RCS file: /home/cvs/modperl-2.0/t/directive/perl.t,v
retrieving revision 1.1
diff -u -I$Id: -r1.1 perl.t
--- t/directive/perl.t 24 Aug 2002 16:12:57 -0000 1.1
+++ t/directive/perl.t 11 Dec 2003 19:42:00 -0000
@@ -4,27 +4,29 @@
use Apache::Test;
use Apache::TestRequest;
-plan tests => 4;
+plan tests => 8;
#so we don't have to require lwp
my @auth = (Authorization => 'Basic ZG91Z206Zm9v'); #dougm:foo
-my $location = "/perl_sections/index.html";
-sok {
- ! GET_OK $location;
-};
-
-sok {
- my $rc = GET_RC $location;
- $rc == 401;
-};
-
-sok {
- GET_OK $location, @auth;
-};
-
-sok {
- ! GET_OK $location, $auth[0], $auth[1] . 'bogus';
-};
+foreach my $location ("/perl_sections/index.html",
+ "/perl_sections_readconfig/index.html") {
+ sok {
+ ! GET_OK $location;
+ };
+
+ sok {
+ my $rc = GET_RC $location;
+ $rc == 401;
+ };
+
+ sok {
+ GET_OK $location, @auth;
+ };
+
+ sok {
+ ! GET_OK $location, $auth[0], $auth[1] . 'bogus';
+ };
+}
Index: t/modperl/.cvsignore
===================================================================
RCS file: /home/cvs/modperl-2.0/t/modperl/.cvsignore,v
retrieving revision 1.14
diff -u -I$Id: -r1.14 .cvsignore
--- t/modperl/.cvsignore 20 Mar 2003 05:49:55 -0000 1.14
+++ t/modperl/.cvsignore 11 Dec 2003 19:42:00 -0000
@@ -14,4 +14,5 @@
request_rec_tie_api.t
perl.t
taint.t
+util.t
Index: t/response/TestDirective/perldo.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestDirective/perldo.pm,v
retrieving revision 1.5
diff -u -I$Id: -r1.5 perldo.pm
--- t/response/TestDirective/perldo.pm 17 Nov 2003 01:11:06 -0000 1.5
+++ t/response/TestDirective/perldo.pm 11 Dec 2003 19:42:00 -0000
@@ -10,15 +10,22 @@
sub handler {
my $r = shift;
- plan $r, tests => 9;
+ plan $r, tests => 11;
ok t_cmp('yes', $TestDirective::perl::worked);
- ok not exists $Apache::ReadConfig::Location{'/perl_sections'};
+ ok t_cmp(qr/t::conf::extra_last_conf::line_\d+$/,
+ $TestDirective::perl::PACKAGE, '__PACKAGE__');
- ok exists $Apache::ReadConfig::Location{'/perl_sections_saved'};
-
- ok t_cmp('PerlSection',
$Apache::ReadConfig::Location{'/perl_sections_saved'}{'AuthName'});
+ my %Location;
+ {
+ no strict 'refs';
+ %Location = %{$TestDirective::perl::PACKAGE . '::Location'};
+ }
+
+ ok not exists $Location{'/perl_sections'};
+ ok exists $Location{'/perl_sections_saved'};
+ ok t_cmp('PerlSection', $Location{'/perl_sections_saved'}{'AuthName'});
ok t_cmp('yes', $TestDirective::perl::comments);
@@ -29,6 +36,8 @@
ok $TestDirective::perl::line > 3;
ok t_cmp("-e", $0, '$0');
+
+ ok t_cmp(1, $TestDirective::perl::Included, "Include");
Apache::OK;
}
Index: t/response/TestModperl/util.pm
===================================================================
RCS file: t/response/TestModperl/util.pm
diff -N t/response/TestModperl/util.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ t/response/TestModperl/util.pm 11 Dec 2003 19:42:00 -0000
@@ -0,0 +1,43 @@
+package TestModperl::util;
+
+use strict;
+use warnings FATAL => 'all';
+
+use ModPerl::Util ();
+
+use Apache::Test;
+use Apache::TestUtil;
+
+use Apache::Const -compile => 'OK';
+
+my %test = (
+ 'simple' => 'simple',
+ 'simple.pm' => 'simple_pm',
+ '/some/path' => 'some::path',
+ '/some/path/file' => 'some::path::file',
+ '/some////path////file' => 'some::path::file',
+ '/some////path////file/' => 'some::path::file',
+ '/some////path////file//' => 'some::path::file',
+ '/some////path////file~//-/' => 'some::path::file_::_',
+ '/some/path/file.pl' => 'some::path::file_pl',
+ '/some/path/with:::bad:chars' => 'some::path::with___bad_chars',
+ '/some/path/...foobar' => 'some::path::___foobar',
+ 'C:\\Windows\\Temp\\SomeFile.bat' => 'C_::Windows::Temp::SomeFile_bat',
+);
+
+sub handler {
+ my $r = shift;
+ my $p = $r->pool;
+
+ plan $r, test => scalar(keys(%test));
+
+ foreach my $f (sort keys %test) {
+ ok t_cmp($test{$f}, ModPerl::Util::file2package($p, $f), $f);
+ }
+
+ Apache::OK;
+}
+
+1;
+__END__
+
Index: xs/ModPerl/Util/ModPerl__Util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h,v
retrieving revision 1.4
diff -u -I$Id: -r1.4 ModPerl__Util.h
--- xs/ModPerl/Util/ModPerl__Util.h 17 Feb 2003 09:03:17 -0000 1.4
+++ xs/ModPerl/Util/ModPerl__Util.h 11 Dec 2003 19:42:00 -0000
@@ -13,5 +13,6 @@
#define mpxs_Apache_current_callback modperl_callback_current_callback_get
+#define mpxs_ModPerl__Util_file2package(pool, filename) modperl_file2package(pool,
filename)
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.61
diff -u -I$Id: -r1.61 modperl_functions.map
--- xs/maps/modperl_functions.map 1 Dec 2003 17:14:16 -0000 1.61
+++ xs/maps/modperl_functions.map 11 Dec 2003 19:42:00 -0000
@@ -3,6 +3,7 @@
MODULE=ModPerl::Util
mpxs_ModPerl__Util_untaint | | ...
DEFINE_exit | | int:status=0
+ char *:DEFINE_file2package | | apr_pool_t *:p, char *:filename
PACKAGE=Apache
char *:DEFINE_current_callback
Index: docs/api/ModPerl/Util.pod
===================================================================
RCS file: /home/cvs/modperl-docs/src/docs/2.0/api/ModPerl/Util.pod,v
retrieving revision 1.1
diff -u -I$Id: -r1.1 Util.pod
--- docs/api/ModPerl/Util.pod 11 Mar 2003 07:33:52 -0000 1.1
+++ docs/api/ModPerl/Util.pod 11 Dec 2003 19:42:00 -0000
@@ -11,11 +11,30 @@
ModPerl::Util::exit();
ModPerl::Util::untaint($) # secret API?
+
+ $package = ModPerl::Util::file2package($p, $filename);
=head1 DESCRIPTION
C<ModPerl::Util> provides mod_perl 2.0 util functions.
-META: complete
+=head1 API
+
+=over
+
+=item * current_callback
+
+Returns the currently running callback, like 'PerlResponseHandler'
+
+=item * file2package(pool, filename)
+
+Will build a safe package name from a filename or path.
+
+=item * exit
+
+Used internally to replace CORE::exit and terminate the request,
+not the whole children.
+
+=back
=cut
Index: todo/release
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/release,v
retrieving revision 1.5
diff -u -I$Id: -r1.5 release
--- todo/release 1 Dec 2003 19:11:19 -0000 1.5
+++ todo/release 11 Dec 2003 19:42:00 -0000
@@ -27,11 +27,6 @@
A few issues with <Perl> sections:
http://marc.theaimsgroup.com/?l=apache-modperl-dev&m=106074969831522&w=2
-* Recursive <Perl> sections:
-
http://www.gossamer-threads.com/archive/mod_perl_C1/dev_F4/%5BMP2_-_BUG_%5D_Issue_handing_Apache_config._error_messages_P70501/
- and
- http://mathforum.org/epigone/modperl/dartrimpcil
-
* Fixing Apache->warn("foo")
Report: http://mathforum.org/epigone/modperl-dev/noxtramcay/[EMAIL PROTECTED]
--
--------------------------------------------------------------------------------
Philippe M. Chiasson /gozer\@(cpan|ectoplasm)\.org/ 88C3A5A5 (122FF51B/C634E37B)
http://gozer.ectoplasm.org/ F9BF E0C2 480E 7680 1AE5 3631 CB32 A107 88C3 A5A5
Q: It is impossible to make anything foolproof because fools are so ingenious.
perl -e'$$=\${gozer};{$_=unpack(P7,pack(L,$$));/^JAm_pH\n$/&&print||$$++&&redo}'
signature.asc
Description: This is a digitally signed message part
