You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by st...@apache.org on 2001/09/28 22:11:02 UTC
cvs commit: modperl-2.0/xs/maps modperl_functions.map
stas 01/09/28 13:11:02
Modified: src/modules/perl modperl_util.h modperl_util.c
t/response/TestAPI request_rec.pm server_rec.pm
xs/Apache/RequestUtil Apache__RequestUtil.h
xs/maps modperl_functions.map
Log:
- 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
Revision Changes Path
1.19 +6 -0 modperl-2.0/src/modules/perl/modperl_util.h
Index: modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- modperl_util.h 2001/09/28 19:24:44 1.18
+++ modperl_util.h 2001/09/28 20:11:01 1.19
@@ -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 */
1.19 +57 -0 modperl-2.0/src/modules/perl/modperl_util.c
Index: modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- modperl_util.c 2001/09/25 19:44:02 1.18
+++ modperl_util.c 2001/09/28 20:11:01 1.19
@@ -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;
+}
1.8 +99 -2 modperl-2.0/t/response/TestAPI/request_rec.pm
Index: request_rec.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPI/request_rec.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- request_rec.pm 2001/09/15 19:34:12 1.7
+++ request_rec.pm 2001/09/28 20:11:02 1.8
@@ -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
+
1.4 +36 -2 modperl-2.0/t/response/TestAPI/server_rec.pm
Index: server_rec.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPI/server_rec.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- server_rec.pm 2001/08/17 03:51:37 1.3
+++ server_rec.pm 2001/09/28 20:11:02 1.4
@@ -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
+
1.7 +4 -1 modperl-2.0/xs/Apache/RequestUtil/Apache__RequestUtil.h
Index: Apache__RequestUtil.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/Apache/RequestUtil/Apache__RequestUtil.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- Apache__RequestUtil.h 2001/09/08 18:26:46 1.6
+++ Apache__RequestUtil.h 2001/09/28 20:11:02 1.7
@@ -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)
1.20 +4 -1 modperl-2.0/xs/maps/modperl_functions.map
Index: modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- modperl_functions.map 2001/09/15 17:57:25 1.19
+++ modperl_functions.map 2001/09/28 20:11:02 1.20
@@ -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 | ...