gozer 2003/12/18 17:17:32
Modified: . Changes
lib/Apache PerlSections.pm
src/modules/perl modperl_cmd.c modperl_util.c modperl_util.h
t/conf extra.last.conf.in
t/directive perl.t
t/response/TestDirective perldo.pm
todo release
Added: t/conf perlsection.conf
Log:
<Perl> are now evaluating code into one distinct namespace per
container, similar to ModPerl::Registry scripts. This finally gets
rid of the many problems reported with recursive perlsections and
infinite recursion.
Revision Changes Path
1.289 +3 -0 modperl-2.0/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.288
retrieving revision 1.289
diff -u -r1.288 -r1.289
--- Changes 18 Dec 2003 00:43:44 -0000 1.288
+++ Changes 19 Dec 2003 01:17:31 -0000 1.289
@@ -12,6 +12,9 @@
=item 1.99_12-dev
+<Perl> are now evaluating code into one distinct namespace per
+container, similar to ModPerl::Registry scripts. [Philippe M. Chiasson]
+
Fix ModPerl::MM::WriteMakefile to use the MODPERL_CCOPTS entry from
Apache::BuildConfig, as it contains some flags added by mod_perl,
which aren't in perl_ccopts and ap_ccopts. [Stas]
1.2 +21 -16 modperl-2.0/lib/Apache/PerlSections.pm
Index: PerlSections.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/PerlSections.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- PerlSections.pm 20 Oct 2003 17:44:48 -0000 1.1
+++ PerlSections.pm 19 Dec 2003 01:17:31 -0000 1.2
@@ -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];
+ }
}
}
}
1.52 +22 -11 modperl-2.0/src/modules/perl/modperl_cmd.c
Index: modperl_cmd.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.c,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- modperl_cmd.c 17 Nov 2003 01:11:06 -0000 1.51
+++ modperl_cmd.c 19 Dec 2003 01:17:31 -0000 1.52
@@ -361,8 +361,11 @@
apr_table_t *options = NULL;
const char *handler_name = NULL;
modperl_handler_t *handler = NULL;
- const char *package_name = NULL;
+ const char *pkg_base = NULL;
+ const char *pkg_namespace = NULL;
+ const char *pkg_name = NULL;
const char *line_header = NULL;
+ ap_directive_t *directive = parms->directive;
int status = OK;
AV *args = Nullav;
SV *dollar_zero = Nullsv;
@@ -397,17 +400,25 @@
handler = modperl_handler_new(p, handler_name);
- if (!(package_name = apr_table_get(options, "package"))) {
- package_name = apr_pstrdup(p, MP_DEFAULT_PERLSECTION_PACKAGE);
- apr_table_set(options, "package", package_name);
+ if (!(pkg_base = apr_table_get(options, "package"))) {
+ pkg_base = apr_pstrdup(p, MP_DEFAULT_PERLSECTION_PACKAGE);
}
+
+ pkg_namespace = modperl_file2package(p, directive->filename);
+
+ pkg_name = apr_psprintf(p, "%s::%s::line_%d",
+ pkg_base,
+ pkg_namespace,
+ directive->line_num);
+
+ apr_table_set(options, "package", pkg_name);
line_header = apr_psprintf(p, "\n#line %d %s\n",
- parms->directive->line_num,
- parms->directive->filename);
+ directive->line_num,
+ directive->filename);
/* put the code about to be executed in the configured package */
- arg = apr_pstrcat(p, "package ", package_name, ";", line_header,
+ arg = apr_pstrcat(p, "package ", pkg_name, ";", line_header,
arg, NULL);
}
@@ -421,7 +432,7 @@
ENTER;
save_item(dollar_zero);
- sv_setpv(dollar_zero, parms->directive->filename);
+ sv_setpv(dollar_zero, directive->filename);
eval_pv(arg, FALSE);
LEAVE;
@@ -436,8 +447,8 @@
}
else {
modperl_log_warn(s, apr_psprintf(p, "Syntax error at %s:%d %s",
- parms->directive->filename,
- parms->directive->line_num,
+ directive->filename,
+ directive->line_num,
SvPVX(ERRSV)));
}
@@ -455,7 +466,7 @@
SvREFCNT_dec((SV*)args);
if (!(saveconfig = MP_PERLSECTIONS_SAVECONFIG_SV) || !SvTRUE(saveconfig)) {
- HV *symtab = (HV*)gv_stashpv(package_name, FALSE);
+ HV *symtab = (HV*)gv_stashpv(pkg_name, FALSE);
if (symtab) {
modperl_clear_symtab(aTHX_ symtab);
}
1.59 +50 -0 modperl-2.0/src/modules/perl/modperl_util.c
Index: modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- modperl_util.c 25 Nov 2003 20:31:29 -0000 1.58
+++ modperl_util.c 19 Dec 2003 01:17:32 -0000 1.59
@@ -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;
+}
1.49 +1 -0 modperl-2.0/src/modules/perl/modperl_util.h
Index: modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- modperl_util.h 22 Sep 2003 23:46:19 -0000 1.48
+++ modperl_util.h 19 Dec 2003 01:17:32 -0000 1.49
@@ -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 */
1.10 +18 -0 modperl-2.0/t/conf/extra.last.conf.in
Index: extra.last.conf.in
===================================================================
RCS file: /home/cvs/modperl-2.0/t/conf/extra.last.conf.in,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- extra.last.conf.in 17 Nov 2003 01:11:06 -0000 1.9
+++ extra.last.conf.in 19 Dec 2003 01:17:32 -0000 1.10
@@ -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>
### --------------------------------- ###
1.1 modperl-2.0/t/conf/perlsection.conf
Index: perlsection.conf
===================================================================
#This is to test re-entrancy of <Perl> blocks
<Perl >
$TestDirective::perl::Included++;
</Perl>
1.2 +20 -18 modperl-2.0/t/directive/perl.t
Index: perl.t
===================================================================
RCS file: /home/cvs/modperl-2.0/t/directive/perl.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- perl.t 24 Aug 2002 16:12:57 -0000 1.1
+++ perl.t 19 Dec 2003 01:17:32 -0000 1.2
@@ -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';
+ };
+}
1.6 +14 -5 modperl-2.0/t/response/TestDirective/perldo.pm
Index: perldo.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestDirective/perldo.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- perldo.pm 17 Nov 2003 01:11:06 -0000 1.5
+++ perldo.pm 19 Dec 2003 01:17:32 -0000 1.6
@@ -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;
}
1.6 +0 -5 modperl-2.0/todo/release
Index: release
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/release,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- release 1 Dec 2003 19:11:19 -0000 1.5
+++ release 19 Dec 2003 01:17:32 -0000 1.6
@@ -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]
