patch:
- implements Apache::RequestRec::dir_config 1.x compliance + allows:
$r->dir_config($key => $val); # == set($key, $val)
$r->dir_config($key => undef); # == unset($key)
- adds tests for dir_config, PerlSetVar and PerlAddVar
the problem I've solved:
- The use of 'items' in TABLE_GET_SET() macro was for a reason, it's all
because 'val' can be undef. And if we make it a char* we lose this
information. Now it's fully 1.x complient.
outstanding issues:
- ALIAS for Apache::Server::dir_config
Doug said: add the common function to modperl_util.c, then it can be
called from anywhere.
Stas replied: can you please be more verbose? what function?
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 10:38:31
@@ -4,11 +4,12 @@
use warnings FATAL => 'all';
use Apache::Test;
+use Apache::TestUtil;
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 +87,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;
@@ -128,6 +203,26 @@
0;
}
+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: xs/modperl_xs_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/modperl_xs_util.h,v
retrieving revision 1.9
diff -u -r1.9 modperl_xs_util.h
--- xs/modperl_xs_util.h 2001/09/25 19:44:03 1.9
+++ xs/modperl_xs_util.h 2001/09/28 10:38:31
@@ -92,4 +92,32 @@
MARK++; \
}
+#define TABLE_GET_SET(table, do_taint) \
+ if (table == NULL) { \
+ RETVAL = &PL_sv_undef; \
+ } \
+ else if (key == NULL) { \
+ RETVAL = modperl_hash_tie(aTHX_ "APR::Table", Nullsv, (void*)table); \
+ } \
+ else if (items > 2) { \
+ if (ST(2) == &PL_sv_undef) { \
+ apr_table_unset(table, key); \
+ } \
+ else { \
+ apr_table_set(table, key, SvPV_nolen(ST(2))); \
+ } \
+ } \
+ else { \
+ char *val; \
+ if ((val = (char *)apr_table_get(table, key))) { \
+ RETVAL = newSVpv(val, 0); \
+ } \
+ else { \
+ RETVAL = newSV(0); \
+ } \
+ if (do_taint) { \
+ SvTAINTED_on(RETVAL); \
+ } \
+ }
+
#endif /* MODPERL_XS_H */
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 10:38:31
@@ -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,48 @@
return retval;
}
+
+static XS(MPXS_Apache__RequestRec_dir_config)
+{
+ dXSARGS;
+
+ if (items < 1 || items > 3) {
+ Perl_croak(aTHX_ "Usage: $r->dir_config($key=NULL, $val=NULL|undef|val)");
+ }
+
+ SP -= items;
+ {
+ char *key;
+ Apache__RequestRec r = modperl_xs_sv2request_rec(aTHX_ ST(0),
+"Apache::RequestRec", cv);
+ SV *RETVAL = &PL_sv_undef;
+
+ if (items < 2) {
+ key = NULL;
+ } else {
+ key = (char *)SvPV_nolen(ST(1));
+ }
+
+ if (r && r->per_dir_config) {
+ MP_dDCFG;
+ TABLE_GET_SET(dcfg->SetVar, FALSE);
+ }
+
+ if (!SvTRUE(RETVAL)) {
+ server_rec *s = r && r->server ? r->server :
+modperl_global_get_server_rec();
+
+ if (s && s->module_config) {
+ MP_dSCFG(s);
+ SvREFCNT_dec(RETVAL); /* in case above did newSV(0) */
+ TABLE_GET_SET(scfg->SetVar, FALSE);
+ } else {
+ RETVAL = &PL_sv_undef;
+ }
+ }
+
+ ST(0) = RETVAL;
+ sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+
+}
+
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 10:38:31
@@ -11,6 +11,7 @@
mpxs_Apache__RequestRec_no_cache | | r, flag=Nullsv
PACKAGE=Apache::RequestRec
mpxs_Apache__RequestRec_new | | classname, c, base_pool=NULL
+DEFINE_dir_config | MPXS_Apache__RequestRec_dir_config | ...
PACKAGE=Apache
mpxs_Apache_request | | classname, svr=Nullsv
_____________________________________________________________________
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]
