dougm 01/11/14 19:02:43
Modified: src/modules/perl mod_perl.c modperl_env.c modperl_env.h
t/conf modperl_extra.pl
t/modperl .cvsignore
Log:
more complete implementation of tie %ENV to r->subprocess_env
Revision Changes Path
1.95 +2 -7 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.94
retrieving revision 1.95
diff -u -r1.94 -r1.95
--- mod_perl.c 2001/11/15 01:30:45 1.94
+++ mod_perl.c 2001/11/15 03:02:42 1.95
@@ -147,6 +147,8 @@
return;
}
+ modperl_env_init();
+
base_perl = modperl_startup(base_server, p);
#ifdef USE_ITHREADS
@@ -538,21 +540,14 @@
h_stdout = modperl_io_tie_stdout(aTHX_ r);
h_stdin = modperl_io_tie_stdin(aTHX_ r);
-#if 0
- /* current implementation of tie %ENV to $r->subprocess_env
- * is not threadsafe
- */
modperl_env_request_tie(aTHX_ r);
-#endif
retval = modperl_response_handler_run(r, FALSE);
modperl_io_handle_untie(aTHX_ h_stdout);
modperl_io_handle_untie(aTHX_ h_stdin);
-#if 0
modperl_env_request_untie(aTHX_ r);
-#endif
modperl_perl_global_request_restore(aTHX_ r);
1.19 +150 -41 modperl-2.0/src/modules/perl/modperl_env.c
Index: modperl_env.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_env.c,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- modperl_env.c 2001/11/12 22:14:36 1.18
+++ modperl_env.c 2001/11/15 03:02:43 1.19
@@ -1,6 +1,7 @@
#include "mod_perl.h"
#define EnvMgObj SvMAGIC((SV*)ENVHV)->mg_ptr
+#define EnvMgLen SvMAGIC((SV*)ENVHV)->mg_len
static MP_INLINE
void modperl_env_hv_store(pTHX_ HV *hv, apr_table_entry_t *elt)
@@ -87,7 +88,6 @@
const apr_array_header_t *array;
apr_table_entry_t *elts;
-
if (MpReqSETUP_ENV(rcfg)) {
return;
}
@@ -118,69 +118,178 @@
MpReqSETUP_ENV_On(rcfg);
}
-static int modperl_env_request_set(pTHX_ SV *sv, MAGIC *mg)
+void modperl_env_request_tie(pTHX_ request_rec *r)
{
- const char *key, *val;
- STRLEN klen, vlen;
- request_rec *r = (request_rec *)EnvMgObj;
+ EnvMgObj = (char *)r;
+ EnvMgLen = -1;
+
+#ifdef MP_PERL_HV_GMAGICAL_AWARE
+ SvGMAGICAL_on((SV*)ENVHV);
+#endif
+}
+
+void modperl_env_request_untie(pTHX_ request_rec *r)
+{
+ EnvMgObj = NULL;
+
+#ifdef MP_PERL_HV_GMAGICAL_AWARE
+ SvGMAGICAL_off((SV*)ENVHV);
+#endif
+}
+
+/* to store the original virtual tables
+ * these are global, not per-interpreter
+ */
+static MGVTBL MP_PERL_vtbl_env;
+static MGVTBL MP_PERL_vtbl_envelem;
- key = (const char *)MgPV(mg,klen);
- val = (const char *)SvPV(sv,vlen);
+#define MP_PL_vtbl_call(name, meth) \
+ MP_PERL_vtbl_##name.svt_##meth(aTHX_ sv, mg)
- apr_table_set(r->subprocess_env, key, val);
+#define MP_dENV_KEY \
+ STRLEN klen; \
+ const char *key = (const char *)MgPV(mg,klen)
+
+#define MP_dENV_VAL \
+ STRLEN vlen; \
+ const char *val = (const char *)SvPV(sv,vlen)
- /*return magic_setenv(sv, mg);*/
+/*
+ * XXX: what we do here might change:
+ * - make it optional for %ENV to be tied to r->subprocess_env
+ * - make it possible to modify environ
+ * - we could allow modification of environ if mpm isn't threaded
+ * - we could allow modification of environ if variable isn't a CGI
+ * variable (still could cause problems)
+ */
+/*
+ * problems we are trying to solve:
+ * - environ is shared between threads
+ * + Perl does not serialize access to environ
+ * + even if it did, CGI variables cannot be shared between threads!
+ * problems we create by trying to solve above problems:
+ * - a forked process will not inherit the current %ENV
+ * - C libraries might rely on environ, e.g. DBD::Oracle
+ */
+static int modperl_env_magic_set_all(pTHX_ SV *sv, MAGIC *mg)
+{
+ request_rec *r = (request_rec *)EnvMgObj;
+ if (r) {
+ if (PL_localizing) {
+ /* local %ENV = (FOO => 'bar', BIZ => 'baz') */
+ HE *entry;
+ STRLEN n_a;
+
+ hv_iterinit((HV*)sv);
+ while ((entry = hv_iternext((HV*)sv))) {
+ I32 keylen;
+ apr_table_set(r->subprocess_env,
+ hv_iterkey(entry, &keylen),
+ SvPV(hv_iterval((HV*)sv, entry), n_a));
+ }
+ }
+ }
+ else {
+ return MP_PL_vtbl_call(env, set);
+ }
+
return 0;
}
-#ifdef MP_PERL_HV_GMAGICAL_AWARE
-static int modperl_env_request_get(pTHX_ SV *sv, MAGIC *mg)
+static int modperl_env_magic_clear_all(pTHX_ SV *sv, MAGIC *mg)
{
- const char *key, *val;
- STRLEN klen;
request_rec *r = (request_rec *)EnvMgObj;
-
- key = (const char *)MgPV(mg,klen);
- if ((val = apr_table_get(r->subprocess_env, key))) {
- sv_setpv(sv, val);
+ if (r) {
+ apr_table_clear(r->subprocess_env);
}
else {
- sv_setsv(sv, &PL_sv_undef);
+ return MP_PL_vtbl_call(env, clear);
}
return 0;
}
-#endif
-/*
- * XXX: PL_vtbl_* are global (not per-interpreter)
- * so this method of tie-ing is not thread-safe
- * overridding svt_get is only useful with 5.7.2+ and requires
- * a smarter lookup than the current modperl_env_request_get
- */
-void modperl_env_request_tie(pTHX_ request_rec *r)
+static int modperl_env_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
- EnvMgObj = (char *)r;
+ request_rec *r = (request_rec *)EnvMgObj;
- PL_vtbl_envelem.svt_set = MEMBER_TO_FPTR(modperl_env_request_set);
-#ifdef MP_PERL_HV_GMAGICAL_AWARE
- SvGMAGICAL_on((SV*)ENVHV);
- PL_vtbl_envelem.svt_get = MEMBER_TO_FPTR(modperl_env_request_get);
-#endif
+ if (r) {
+ MP_dENV_KEY;
+ MP_dENV_VAL;
+ apr_table_set(r->subprocess_env, key, val);
+ }
+ else {
+ return MP_PL_vtbl_call(envelem, set);
+ }
+
+ return 0;
}
-void modperl_env_request_untie(pTHX_ request_rec *r)
+static int modperl_env_magic_clear(pTHX_ SV *sv, MAGIC *mg)
{
-#if 0
- /* XXX: not currently in use. if enabled Perl_magic_setenv
- * is not available to win32
- */
- PL_vtbl_envelem.svt_set = MEMBER_TO_FPTR(Perl_magic_setenv);
-#endif
+ request_rec *r = (request_rec *)EnvMgObj;
+
+ if (r) {
+ MP_dENV_KEY;
+ apr_table_unset(r->subprocess_env, key);
+ }
+ else {
+ return MP_PL_vtbl_call(envelem, clear);
+ }
+
+ return 0;
+}
+
#ifdef MP_PERL_HV_GMAGICAL_AWARE
- SvGMAGICAL_off((SV*)ENVHV);
- PL_vtbl_envelem.svt_get = 0;
+static int modperl_env_magic_get(pTHX_ SV *sv, MAGIC *mg)
+{
+ request_rec *r = (request_rec *)EnvMgObj;
+
+ if (r) {
+ MP_dENV_KEY;
+ const char *val;
+
+ if ((val = apr_table_get(r->subprocess_env, key))) {
+ sv_setpv(sv, val);
+ }
+ else {
+ sv_setsv(sv, &PL_sv_undef);
+ }
+ }
+ else {
+ /* there is no svt_get in PL_vtbl_envelem */
+ }
+
+ return 0;
+}
#endif
+
+/* override %ENV virtual tables with our own */
+static MGVTBL MP_vtbl_env = {
+ 0,
+ MEMBER_TO_FPTR(modperl_env_magic_set_all),
+ 0,
+ MEMBER_TO_FPTR(modperl_env_magic_clear_all),
+ 0
+};
+
+static MGVTBL MP_vtbl_envelem = {
+ 0,
+ MEMBER_TO_FPTR(modperl_env_magic_set),
+ 0,
+ MEMBER_TO_FPTR(modperl_env_magic_clear),
+ 0
+};
+
+void modperl_env_init(void)
+{
+ /* save originals */
+ StructCopy(&PL_vtbl_env, &MP_PERL_vtbl_env, MGVTBL);
+ StructCopy(&PL_vtbl_envelem, &MP_PERL_vtbl_envelem, MGVTBL);
+
+ /* replace with our versions */
+ StructCopy(&MP_vtbl_env, &PL_vtbl_env, MGVTBL);
+ StructCopy(&MP_vtbl_envelem, &PL_vtbl_envelem, MGVTBL);
}
1.10 +2 -0 modperl-2.0/src/modules/perl/modperl_env.h
Index: modperl_env.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_env.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- modperl_env.h 2001/10/13 19:11:32 1.9
+++ modperl_env.h 2001/11/15 03:02:43 1.10
@@ -23,4 +23,6 @@
void modperl_env_request_untie(pTHX_ request_rec *r);
+void modperl_env_init(void);
+
#endif /* MODPERL_ENV_H */
1.10 +3 -0 modperl-2.0/t/conf/modperl_extra.pl
Index: modperl_extra.pl
===================================================================
RCS file: /home/cvs/modperl-2.0/t/conf/modperl_extra.pl,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- modperl_extra.pl 2001/10/09 18:01:21 1.9
+++ modperl_extra.pl 2001/11/15 03:02:43 1.10
@@ -18,6 +18,9 @@
die '$ENV{MOD_PERL} not set!';
}
+#see t/response/TestModperl/env.pm
+$ENV{MODPERL_EXTRA_PL} = __FILE__;
+
my $ap_mods = scalar grep { /^Apache/ } keys %INC;
my $apr_mods = scalar grep { /^APR/ } keys %INC;
1.7 +1 -0 modperl-2.0/t/modperl/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /home/cvs/modperl-2.0/t/modperl/.cvsignore,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- .cvsignore 2001/11/13 18:35:08 1.6
+++ .cvsignore 2001/11/15 03:02:43 1.7
@@ -1,3 +1,4 @@
+env.t
endav.t
exit.t
printf.t
