dougm 00/06/13 14:05:55
Modified: lib/ModPerl Code.pm
pod modperl_dev.pod
src/modules/perl mod_perl.c mod_perl.h modperl_callback.c
modperl_config.c modperl_config.h modperl_types.h
Log:
first cut of PerlOptions directive
Revision Changes Path
1.30 +46 -15 modperl-2.0/lib/ModPerl/Code.pm
Index: Code.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/Code.pm,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- Code.pm 2000/06/12 19:37:25 1.29
+++ Code.pm 2000/06/13 21:05:35 1.30
@@ -81,15 +81,17 @@
$directive_proto{$k}->{ret} = 'const char *';
}
+#XXX: allow disabling of PerDir hooks on a PerDir basis
+my @hook_flags = (map { canon_uc($_) } keys %hooks);
my %flags = (
- Srv => [qw(NONE PERL_TAINT_CHECK PERL_WARN FRESH_RESTART
- PERL_CLONE PERL_ALLOC PERL_OFF UNSET)],
- Dir => [qw(NONE INCPUSH SENDHDR SENTHDR ENV CLEANUP RCLEANUP)],
+ Srv => [qw(NONE CLONE PARENT ENABLED), @hook_flags, 'UNSET'],
+ Dir => [qw(NONE SEND_HEADER SETUP_ENV UNSET)],
Interp => [qw(NONE IN_USE PUTBACK CLONED BASE)],
Handler => [qw(NONE PARSED METHOD OBJECT ANON)],
);
-my %flags_lookup = map { $_,1 } qw(Srv);
+my %flags_lookup = map { $_,1 } qw(Srv Dir);
+my %flags_options = map { $_,1 } qw(Srv);
sub new {
my $class = shift;
@@ -201,10 +203,11 @@
my $i = 0;
for my $h (@$handlers) {
+ my $h_name = join $h, qw(Perl Handler);
my $name = canon_func('cmd', $h, 'handlers');
my $cmd_name = canon_define('cmd', $h, 'entry');
my $protostr = canon_proto($prototype, $name);
-
+ my $flag = 'MpSrv' . canon_uc($h);
my $ix = $self->{handler_index}->{$class}->[$i++];
my $av = "$prototype->{cfg}->{name}->handlers[$ix]";
@@ -215,7 +218,7 @@
print $h_fh <<EOF;
#define $cmd_name \\
-{"Perl${h}Handler", $name, NULL, \\
+{"$h_name", $name, NULL, \\
$prototype->{scope}, ITERATE, "Subroutine name"}
EOF
@@ -223,11 +226,16 @@
$protostr
{
$prototype->{cfg}->{get};
- if (MpSrvPERL_OFF(scfg)) {
+ if (!MpSrvENABLED(scfg)) {
return ap_pstrcat(parms->pool,
"Perl is disabled for server ",
parms->server->server_hostname, NULL);
}
+ if (!$flag(scfg)) {
+ return ap_pstrcat(parms->pool,
+ "$h_name is disabled for server ",
+ parms->server->server_hostname, NULL);
+ }
MP_TRACE_d(MP_FUNC, "push \@%s, %s\\n", parms->cmd->name, arg);
return modperl_cmd_push_handlers(&($av), arg, parms->pool);
}
@@ -243,24 +251,34 @@
sub generate_flags {
my($self, $h_fh, $c_fh) = @_;
+ my $n = 1;
+
while (my($class, $opts) = each %{ $self->{flags} }) {
my $i = 0;
my @lookup = ();
my $lookup_proto = "";
+ my @dumper;
if ($flags_lookup{$class}) {
$lookup_proto = join canon_func('flags', 'lookup', $class),
- 'int ', '(const char *str)';
+ 'U32 ', '(const char *str)';
push @lookup, "$lookup_proto {";
}
+
+ my $flags = join $class, qw(Mp FLAGS);
- print $h_fh "\n#define Mp${class}FLAGS(p) p->flags\n";
+ print $h_fh "\n#define $flags(p) ",
+ ($flags_options{$class} ? '(p)->flags->opts' : '(p)->flags'), "\n";
+
$class = "Mp$class";
+ print $h_fh "\n#define ${class}Type $n\n";
+ $n++;
for my $f (@$opts) {
my $flag = "${class}_f_$f";
my $cmd = $class . $f;
+ my $name = canon_name($f);
+
if (@lookup) {
- my $name = canon_name($f);
push @lookup, qq( if (strEQ(str, "$name")) return $flag;);
}
@@ -268,19 +286,32 @@
/* $f */
#define $flag $i
-#define $cmd(p) ((p)->flags & $flag)
-#define ${cmd}_On(p) ((p)->flags |= $flag)
-#define ${cmd}_Off(p) ((p)->flags &= ~$flag)
+#define $cmd(p) ($flags(p) & $flag)
+#define ${cmd}_On(p) ($flags(p) |= $flag)
+#define ${cmd}_Off(p) ($flags(p) &= ~$flag)
EOF
+ push @dumper,
+ qq{fprintf(stderr, " $name %s\\n", \\
+ ($flags(p) & $i) ? "On " : "Off");};
+
$i += $i || 1;
}
if (@lookup) {
- print $c_fh join "\n", @lookup, " return -1;\n}\n";
+ print $c_fh join "\n", @lookup, " return 0;\n}\n";
print $h_fh "$lookup_proto;\n";
}
+
+ shift @dumper; #NONE
+ print $h_fh join ' \\'."\n",
+ "#define ${class}_dump_flags(p, str)",
+ qq{fprintf(stderr, "$class flags dump (%s):\\n", str);},
+ @dumper;
}
+ print $h_fh "\n#define MpSrvHOOKS_ALL_On(p) MpSrvFLAGS(p) |= (",
+ (join '|', map { 'MpSrv_f_' . $_ } @hook_flags), ")\n";
+
();
}
@@ -408,7 +439,7 @@
generate_trace => {h => 'modperl_trace.h'},
);
-my @c_src_names = qw(interp tipool log config callback gtop);
+my @c_src_names = qw(interp tipool log config options callback gtop);
my @g_c_names = map { "modperl_$_" } qw(hooks directives flags xsinit);
my @c_names = ('mod_perl', (map "modperl_$_", @c_src_names));
sub c_files { [map { "$_.c" } @c_names, @g_c_names] }
1.3 +58 -0 modperl-2.0/pod/modperl_dev.pod
Index: modperl_dev.pod
===================================================================
RCS file: /home/cvs/modperl-2.0/pod/modperl_dev.pod,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- modperl_dev.pod 2000/06/09 07:58:25 1.2
+++ modperl_dev.pod 2000/06/13 21:05:36 1.3
@@ -176,3 +176,61 @@
Max number of requests per Perl interpreters
=back
+
+=head2 PerlOptions Directive
+
+Enable/Disable Options. Options include:
+
+=over 4
+
+=item Parent
+
+Create a new parent Perl interpreter for the given VirtualHost
+(implies Clone).
+
+=item Clone
+
+Give the VirtualHost its own interpreter pool.
+
+=item Enabled
+
+On by default, used to disable mod_perl for a given VirtualHost.
+
+=item Perl*Handler
+
+Disable Perl*Handlers, all compiled in handlers are enabled by default.
+
+=back
+
+Examples:
+
+ #disable mod_perl for this host
+ <VirtualHost ...>
+ PerlOptions -Enable
+ </VirtualHost>
+
+ #create 2 Parent Perls,
+ #each pointing to a different developer library tree
+ <VirtualHost ...>
+ ServerName dev1
+ PerlOptions +Parent
+ PerlSwitches -Mblib=/home/dev1/lib/perl
+ </VirtualHost>
+
+ <VirtualHost ...>
+ ServerName dev2
+ PerlOptions +Parent
+ PerlSwitches -Mblib=/home/dev2/lib/perl
+ </VirtualHost>
+
+ #give VirtualHost its own interpreter pool
+ <VirtualHost ...>
+ PerlOptions +Clone
+ PerlInterpStart 2
+ PerlInterpMax 2
+ </VirtualHost>
+
+ #disable handlers
+ <VirtualHost ...>
+ PerlOptions -Authen -Authz -Access
+ </VirtualHost>
\ No newline at end of file
1.18 +10 -20 modperl-2.0/src/modules/perl/mod_perl.c
Index: mod_perl.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.c,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mod_perl.c 2000/06/12 19:37:26 1.17
+++ mod_perl.c 2000/06/13 21:05:39 1.18
@@ -50,7 +50,10 @@
ap_get_module_config(base_server->module_config, &perl_module);
PerlInterpreter *base_perl;
- if (MpSrvPERL_OFF(base_scfg)) {
+ MP_TRACE_d_do(MpSrv_dump_flags(base_scfg,
+ base_server->server_hostname));
+
+ if (!MpSrvENABLED(base_scfg)) {
/* how silly */
return;
}
@@ -63,30 +66,16 @@
MP_dSCFG(s);
PerlInterpreter *perl = base_perl;
- if (1) {
- /* XXX: using getenv() just for testing here */
- char *do_alloc = getenv("MP_SRV_ALLOC_TEST");
- char *do_clone = getenv("MP_SRV_CLONE_TEST");
- char *do_off = getenv("MP_SRV_OFF_TEST");
- if (do_alloc && strEQ(do_alloc, s->server_hostname)) {
- MpSrvPERL_ALLOC_On(scfg);
- }
- if (do_clone && strEQ(do_clone, s->server_hostname)) {
- MpSrvPERL_CLONE_On(scfg);
- }
- if (do_off && strEQ(do_off, s->server_hostname)) {
- MpSrvPERL_OFF_On(scfg);
- }
- }
+ MP_TRACE_d_do(MpSrv_dump_flags(scfg, s->server_hostname));
/* if alloc flags is On, virtual host gets its own parent perl */
- if (MpSrvPERL_ALLOC(scfg)) {
+ if (MpSrvPARENT(scfg)) {
perl = modperl_startup(s, p);
MP_TRACE_i(MP_FUNC, "modperl_startup() server=%s\n",
s->server_hostname);
}
- if (MpSrvPERL_OFF(scfg)) {
+ if (!MpSrvENABLED(scfg)) {
scfg->mip = NULL;
continue;
}
@@ -95,14 +84,14 @@
/* if alloc flags is On or clone flag is On,
* virtual host gets its own mip
*/
- if (MpSrvPERL_ALLOC(scfg) || MpSrvPERL_CLONE(scfg)) {
+ if (MpSrvPARENT(scfg) || MpSrvCLONE(scfg)) {
MP_TRACE_i(MP_FUNC, "modperl_interp_init() server=%s\n",
s->server_hostname);
modperl_interp_init(s, p, perl);
}
/* if we allocated a parent perl, mark it to be destroyed */
- if (MpSrvPERL_ALLOC(scfg)) {
+ if (MpSrvPARENT(scfg)) {
MpInterpBASE_On(scfg->mip->parent);
}
@@ -137,6 +126,7 @@
static command_rec modperl_cmds[] = {
MP_SRV_CMD_ITERATE("PerlSwitches", switches, "Perl Switches"),
+ MP_SRV_CMD_ITERATE("PerlOptions", options, "Perl Options"),
#ifdef MP_TRACE
MP_SRV_CMD_TAKE1("PerlTrace", trace, "Trace level"),
#endif
1.15 +1 -1 modperl-2.0/src/modules/perl/mod_perl.h
Index: mod_perl.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.h,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- mod_perl.h 2000/05/23 20:54:44 1.14
+++ mod_perl.h 2000/06/13 21:05:39 1.15
@@ -37,7 +37,7 @@
#include "modperl_tipool.h"
#include "modperl_interp.h"
#include "modperl_log.h"
-
+#include "modperl_options.h"
#include "modperl_directives.h"
void modperl_init(server_rec *s, ap_pool_t *p);
1.12 +1 -1 modperl-2.0/src/modules/perl/modperl_callback.c
Index: modperl_callback.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_callback.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- modperl_callback.c 2000/06/12 19:37:27 1.11
+++ modperl_callback.c 2000/06/13 21:05:39 1.12
@@ -316,7 +316,7 @@
int i, status = OK;
const char *desc = NULL;
- if (MpSrvPERL_OFF(scfg)) {
+ if (!MpSrvENABLED(scfg)) {
MP_TRACE_h(MP_FUNC, "PerlOff for server %s\n",
s->server_hostname);
return DECLINED;
1.12 +24 -0 modperl-2.0/src/modules/perl/modperl_config.c
Index: modperl_config.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_config.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- modperl_config.c 2000/06/12 03:30:52 1.11
+++ modperl_config.c 2000/06/13 21:05:39 1.12
@@ -56,6 +56,10 @@
modperl_srv_config_t *scfg = (modperl_srv_config_t *)
ap_pcalloc(p, sizeof(*scfg));
+ scfg->flags = modperl_options_new(p, MpSrvType);
+ MpSrvENABLED_On(scfg); /* mod_perl enabled by default */
+ MpSrvHOOKS_ALL_On(scfg); /* all hooks enabled by default */
+
scfg->argv = ap_make_array(p, 2, sizeof(char *));
scfg_push_argv((char *)ap_server_argv0);
@@ -154,17 +158,21 @@
merge_item(perl);
#endif
+ merge_item(argv);
merge_item(files_cfg);
merge_item(process_cfg);
merge_item(connection_cfg);
{ /* XXX: should do a proper merge of the arrays */
+ /* XXX: and check if Perl*Handler is disabled */
int i;
for (i=0; i<MP_PER_SRV_NUM_HANDLERS; i++) {
merge_item(handlers[i]);
}
}
+ mrg->flags = modperl_options_merge(p, base->flags, add->flags);
+
return mrg;
}
@@ -192,6 +200,22 @@
{
MP_dSCFG(parms->server);
scfg_push_argv(arg);
+ return NULL;
+}
+
+MP_DECLARE_SRV_CMD(options)
+{
+ MP_dSCFG(parms->server);
+ ap_pool_t *p = parms->pool;
+ const char *error;
+
+ MP_TRACE_d(MP_FUNC, "arg = %s\n", arg);
+ error = modperl_options_set(p, scfg->flags, arg);
+
+ if (error) {
+ return error;
+ }
+
return NULL;
}
1.11 +1 -0 modperl-2.0/src/modules/perl/modperl_config.h
Index: modperl_config.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_config.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- modperl_config.h 2000/05/23 20:54:44 1.10
+++ modperl_config.h 2000/06/13 21:05:39 1.11
@@ -24,6 +24,7 @@
void *dummy, char *arg)
MP_DECLARE_SRV_CMD(trace);
MP_DECLARE_SRV_CMD(switches);
+MP_DECLARE_SRV_CMD(options);
#ifdef USE_ITHREADS
MP_DECLARE_SRV_CMD(interp_start);
1.14 +11 -1 modperl-2.0/src/modules/perl/modperl_types.h
Index: modperl_types.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_types.h,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- modperl_types.h 2000/05/26 20:34:50 1.13
+++ modperl_types.h 2000/06/13 21:05:39 1.14
@@ -102,7 +102,17 @@
MpAV *handlers[MP_FILES_NUM_HANDLERS];
} modperl_files_config_t;
+typedef U32 modperl_opts_t;
+
typedef struct {
+ modperl_opts_t opts;
+ modperl_opts_t opts_add;
+ modperl_opts_t opts_remove;
+ modperl_opts_t opts_override;
+ int unset;
+} modperl_options_t;
+
+typedef struct {
MpHV *SetVars;
MpAV *PassEnv;
MpAV *PerlRequire, *PerlModule;
@@ -120,7 +130,7 @@
modperl_gtop_t *gtop;
#endif
MpAV *argv;
- int flags;
+ modperl_options_t *flags;
} modperl_srv_config_t;
typedef struct {
