this patch:
- implements modperl_table_get_set for other functions to use
- implements Apache::Server::dir_config + tests
- implements Apache::RequestRec::dir_config + tests
- implements new features coming from modperl_table_get_set for free
$(s|r)->dir_config($key => $val); # == set($key, $val)
$(s|r)r->dir_config($key => undef); # == unset($key)
- adds tests for PerlSetVar and PerlAddVar via dir_config
open issues: Apache::Server doesn't bootstap subs from Apache::ServerUtil
(doesn't use/require), I've done this with use() in the test, where I
needed it. Not sure what's the right thing to do here.
Index: src/modules/perl/modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.18
diff -u -r1.18 modperl_util.h
--- src/modules/perl/modperl_util.h 2001/09/28 19:24:44 1.18
+++ src/modules/perl/modperl_util.h 2001/09/28 19:52:03
@@ -66,4 +66,10 @@
MP_INLINE void *modperl_hash_tied_object(pTHX_ const char *classname,
SV *tsv);
+MP_INLINE SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
+ char *key, SV *sv_val);
+
+SV *modperl_table_get_set(pTHX_ apr_table_t *table, char *key,
+ SV *sv_val, bool do_taint);
+
#endif /* MODPERL_UTIL_H */
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.18
diff -u -r1.18 modperl_util.c
--- src/modules/perl/modperl_util.c 2001/09/25 19:44:02 1.18
+++ src/modules/perl/modperl_util.c 2001/09/28 19:52:03
@@ -386,3 +386,60 @@
return NULL;
}
+
+MP_INLINE
+SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
+ char *key, SV *sv_val)
+{
+ SV *RETVAL = &PL_sv_undef;
+
+ if (r && r->per_dir_config) {
+ MP_dDCFG;
+ RETVAL = modperl_table_get_set(aTHX_ dcfg->SetVar, key, sv_val, FALSE);
+ }
+
+ if (!SvTRUE(RETVAL)) {
+ if (s && s->module_config) {
+ MP_dSCFG(s);
+ SvREFCNT_dec(RETVAL); /* in case above did newSV(0) */
+ RETVAL = modperl_table_get_set(aTHX_ scfg->SetVar, key, sv_val, FALSE);
+ } else {
+ RETVAL = &PL_sv_undef;
+ }
+ }
+
+ return RETVAL;
+}
+
+SV *modperl_table_get_set(pTHX_ apr_table_t *table, char *key,
+ SV *sv_val, bool do_taint)
+{
+ SV *RETVAL = &PL_sv_undef;
+
+ if (table == NULL) {
+ /* do nothing */
+ }
+ else if (key == NULL) {
+ RETVAL = modperl_hash_tie(aTHX_ "APR::Table", Nullsv, (void*)table);
+ }
+ else if (sv_val == &PL_sv_no) { /* no val was passed */
+ char *val;
+ if ((val = (char *)apr_table_get(table, key))) {
+ RETVAL = newSVpv(val, 0);
+ }
+ else {
+ RETVAL = newSV(0);
+ }
+ if (do_taint) {
+ SvTAINTED_on(RETVAL);
+ }
+ }
+ else if (sv_val == &PL_sv_undef) { /* val was passed in as undef */
+ apr_table_unset(table, key);
+ }
+ else {
+ apr_table_set(table, key, SvPV_nolen(sv_val));
+ }
+
+ return RETVAL;
+}
Index: t/response/TestAPI/request_rec.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPI/request_rec.pm,v
retrieving revision 1.7
diff -u -r1.7 request_rec.pm
--- t/response/TestAPI/request_rec.pm 2001/09/15 19:34:12 1.7
+++ t/response/TestAPI/request_rec.pm 2001/09/28 19:52:03
@@ -4,11 +4,14 @@
use warnings FATAL => 'all';
use Apache::Test;
+use Apache::TestUtil;
+use Apache::Const -compile => 'OK';
+
sub handler {
my $r = shift;
- plan $r, tests => 40;
+ plan $r, tests => 48;
#Apache->request($r); #PerlOptions +GlobalRequest takes care
my $gr = Apache->request;
@@ -86,6 +89,80 @@
#user
+ #<- dir_config tests ->#
+
+ # this test doesn't test all $r->dir_config->*(), since
+ # dir_config() returns a generic APR::Table which is tested in
+ # apr/table.t.
+
+ # object test
+ my $dir_config = $r->dir_config;
+ ok defined $dir_config && ref($dir_config) eq 'APR::Table';
+
+ # PerlAddVar ITERATE2 test
+ {
+ my $key = make_key('1');
+ my @received = $dir_config->get($key);
+ my @expected = qw(1_SetValue 2_AddValue 3_AddValue 4_AddValue);
+ ok t_cmp(
+ \@expected,
+ \@received,
+ "testing PerlAddVar ITERATE2",
+ )
+ }
+
+ {
+ my $key = make_key('0');
+
+ # object interface test in a scalar context (for a single
+ # PerlSetVar key)
+ ok t_cmp("SetValue0",
+ $dir_config->get($key),
+ qq{\$dir_config->get("$key")});
+
+ # direct fetch test in a scalar context (for a single
+ # PerlSetVar)
+ ok t_cmp("SetValue0",
+ $r->dir_config($key),
+ qq{\$r->dir_config("$key")});
+ }
+
+ # test non-existent key
+ {
+ my $key = make_key();
+ ok t_cmp(undef,
+ $r->dir_config($key),
+ qq{\$r->dir_config("$key")});
+ }
+
+ # test set interface
+ {
+ my $key = make_key();
+ my $val = "DirConfig";
+ $r->dir_config($key => $val);
+ ok t_cmp($val,
+ $r->dir_config($key),
+ qq{\$r->dir_config($key => $val)});
+ }
+
+ # test unset interface
+ {
+ my $key = make_key();
+ $r->dir_config($key => 'whatever');
+ $r->dir_config($key => undef);
+ ok t_cmp(undef,
+ $r->dir_config($key),
+ qq{\$r->dir_config($key => undef)});
+ }
+
+ # test PerlSetVar set in base config
+ {
+ my $key = make_key('_set_in_Base');
+ ok t_cmp("BaseValue",
+ $r->dir_config($key),
+ qq{\$r->dir_config("$key")});
+ }
+
#no_cache
ok $r->no_cache || 1;
@@ -125,9 +202,29 @@
#eos_sent
- 0;
+ Apache::OK;
}
+my $key_base = "TestAPI__request_rec_Key";
+my $counter = 0;
+sub make_key{
+ return $key_base .
+ (defined $_[0]
+ ? $_[0]
+ : unpack "H*", pack "n", ++$counter . rand(100) );
+}
1;
__END__
+<Base>
+ PerlSetVar TestAPI__request_rec_Key_set_in_Base BaseValue
+</Base>
PerlOptions +GlobalRequest
+
+PerlSetVar TestAPI__request_rec_Key0 SetValue0
+
+
+PerlSetVar TestAPI__request_rec_Key1 ToBeLost
+PerlSetVar TestAPI__request_rec_Key1 1_SetValue
+PerlAddVar TestAPI__request_rec_Key1 2_AddValue
+PerlAddVar TestAPI__request_rec_Key1 3_AddValue 4_AddValue
+
Index: t/response/TestAPI/server_rec.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPI/server_rec.pm,v
retrieving revision 1.3
diff -u -r1.3 server_rec.pm
--- t/response/TestAPI/server_rec.pm 2001/08/17 03:51:37 1.3
+++ t/response/TestAPI/server_rec.pm 2001/09/28 19:52:03
@@ -4,13 +4,17 @@
use warnings FATAL => 'all';
use Apache::Test;
+use Apache::TestUtil;
+use Apache::ServerUtil;
+use Apache::Const -compile => 'OK';
+
sub handler {
my $r = shift;
my $s = $r->server;
- plan $r, tests => 17;
+ plan $r, tests => 19;
ok $s;
@@ -55,8 +59,38 @@
ok $s->limit_req_fieldsize;
ok $s->limit_req_fields;
+
+
+ #<- dir_config tests ->#
- 0;
+ # this test doesn't test all $s->dir_config->*(), since
+ # dir_config() returns a generic APR::Table which is tested in
+ # apr/table.t.
+
+ # object test
+ my $dir_config = $s->dir_config;
+ ok defined $dir_config && ref($dir_config) eq 'APR::Table';
+
+ # PerlAddVar ITERATE2 test
+ {
+ my $key = 'TestAPI__server_rec_Key_set_in_Base';
+ my @received = $dir_config->get($key);
+ my @expected = qw(1_SetValue 2_AddValue 3_AddValue);
+ ok t_cmp(
+ \@expected,
+ \@received,
+ "testing PerlAddVar ITERATE2 in $s",
+ )
+ }
+ Apache::OK;
}
1;
+
+__END__
+<Base>
+ PerlSetVar TestAPI__server_rec_Key_set_in_Base 1_SetValue
+ PerlAddVar TestAPI__server_rec_Key_set_in_Base 2_AddValue 3_AddValue
+</Base>
+PerlSetVar TestAPI__server_rec_Key_set_in_Base WhatEver
+
Index: xs/Apache/RequestUtil/Apache__RequestUtil.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/Apache/RequestUtil/Apache__RequestUtil.h,v
retrieving revision 1.6
diff -u -r1.6 Apache__RequestUtil.h
--- xs/Apache/RequestUtil/Apache__RequestUtil.h 2001/09/08 18:26:46 1.6
+++ xs/Apache/RequestUtil/Apache__RequestUtil.h 2001/09/28 19:52:03
@@ -168,7 +168,7 @@
if (r->no_cache) {
apr_table_setn(r->headers_out, "Pragma", "no-cache");
apr_table_setn(r->headers_out, "Cache-control", "no-cache");
- }
+ }
else if (flag) { /* only unset if $r->no_cache(0) */
apr_table_unset(r->headers_out, "Pragma");
apr_table_unset(r->headers_out, "Cache-control");
@@ -176,3 +176,6 @@
return retval;
}
+
+#define mpxs_Apache__RequestRec_dir_config(r, key, sv_val) \
+ modperl_dir_config(aTHX_ r, r->server, key, sv_val)
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.19
diff -u -r1.19 modperl_functions.map
--- xs/maps/modperl_functions.map 2001/09/15 17:57:25 1.19
+++ xs/maps/modperl_functions.map 2001/09/28 19:52:03
@@ -11,6 +11,7 @@
mpxs_Apache__RequestRec_no_cache | | r, flag=Nullsv
PACKAGE=Apache::RequestRec
mpxs_Apache__RequestRec_new | | classname, c, base_pool=NULL
+ SV *:DEFINE_dir_config | | request_rec *:r, char *:key=NULL, SV *:sv_val=&PL_sv_no
PACKAGE=Apache
mpxs_Apache_request | | classname, svr=Nullsv
@@ -34,6 +35,9 @@
mpxs_Apache__Server_set_handlers
mpxs_Apache__Server_get_handlers
+MODULE=Apache::ServerUtil PACKAGE=Apache::Server
+ SV *:DEFINE_dir_config | | server_rec *:s, char *:key=NULL, SV *:sv_val=&PL_sv_no
+
MODULE=Apache::Filter
modperl_filter_attributes | MPXS_ | ... | MODIFY_CODE_ATTRIBUTES
@@ -66,6 +70,5 @@
DEFINE_warn | MPXS_Apache__Log_log_error | ...
PACKAGE=Apache
-
DEFINE_LOG_MARK | MPXS_Apache_LOG_MARK | ...
DEFINE_warn | MPXS_Apache__Log_log_error | ...
_____________________________________________________________________
Stas Bekman JAm_pH -- Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide http://perl.apache.org/guide
mailto:[EMAIL PROTECTED] http://apachetoday.com http://eXtropia.com/
http://singlesheaven.com http://perl.apache.org http://perlmonth.com/
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
