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 {