Please take our Survey
logo       
<prev   next>

Choosing A Webhost:
A web hosting service is a type of Internet hosting service that allows individuals and organizations to provide their own website accessible via the World Wide Web. Web hosts are companies that provide space on a server they own for use by their clients as well as providing Internet connectivity, typically in a data center. Web hosts can also provide data center space and connectivity to the Internet for servers they do not own to be located in their data center, called colocation. more...

[Patch mp2] #3 PerlSections namespace: msg#00163

apache.mod-perl.devel

Subject: [Patch mp2] #3 PerlSections namespace

After making the small changes we discussed, here is a simpler version
of the original <Perl> namespace patch, without exposing it thru
ModPerl::Util and a few style tweaks as per stas's recommendations.

? Doxyfile
? SIGNATURE
? dox
? foo
? perlsection.diff
? src.diff
? build/indent
? lib/C
? lib/threads
? t/modperl/util.t
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 15 Dec 2003 23:13:28 -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, \@ENTRY];
- }
- 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, \@ENTRY];
+ }
+ if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) {
+ push @{$self->{symbols}}, [$key, \%ENTRY];
+ }
}
}
}
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 15 Dec 2003 23:13:28 -0000
@@ -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);
}
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 15 Dec 2003 23:13:28 -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 15 Dec 2003 23:13:28 -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: 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 15 Dec 2003 23:13:28 -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 15 Dec 2003 23:13:28 -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 15 Dec 2003 23:13:28 -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/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 15 Dec 2003 23:13:28 -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: 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 15 Dec 2003 23:13:28 -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/3D11A4E5.6010202@xxxxxxxxxx


--------------------------------------------------------------------------------
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}'

Attachment: signature.asc
Description: This is a digitally signed message part
<Prev in Thread] Current Thread [Next in Thread>
Previous by Date:  Re: [Patch mp2] #2 PerlSections namespace, Stas Bekman
Next by Date:  Re: cvs commit: modperl-2.0 Changes, Philippe M. Chiasson
Previous by Thread:  Re: [Patch mp2] #2 PerlSections namespace, Stas Bekman
Next by Thread:  Re: [Patch mp2] #3 PerlSections namespace, Stas Bekman
Indexes:  [Date] [Thread] [Top] [All Lists]

Google Custom Search
Recently Viewed:
solaris.opensol...    editors.vim/200...    web.turbogears....    jakarta.ant.dev...    mathematics.max...    text.unicode.ge...    lang.ruby.core/...    xfce.announce/2...    network.centeri...    php.cvs.pear/20...    user-groups.lin...    kde.devel.quant...    file-systems.ar...    redhat.fedora.t...    apple.fink.auto...    gnome.orbit.gen...    qplus.devel/200...    culture.transpo...    video.dri.user/...    operators.nanog...   
Home | advertise | OSDir is an inevitable website. super tiny logo

Free Magazines

Cisco News
Receive a free quarterly e-newsletter with exclusive articles on how Cisco IT uses its own products and solutions to enable the business.
subscribe

Systems Management News, the newspaper for IT systems administration and data center managers! Each issue of Systems Management News is chock-full of news and analysis to help you understand what's happening in your field.
subscribe

The Enterprise Newsweekly eWeek is the essential technology information source for builders of e-business.
subscribe

Oracle Magazine Oracle Magazine contains technology strategy articles, sample code, tips, Oracle and partner news, how to articles for developers and DBAs, and more. Oracle (NASDAQ: ORCL) is the world's largest enterprise software company.
subscribe

Total Telecom Total Telecom is "The Economist of the communications industry".
subscribe

Navigation