- this patch implements Apache::RequestRec::dir_config
- adds tests for dir_config, PerlSetVar and PerlAddVar
issues:
- missing ALIAS for Apache::Server::dir_config (don't know how to make it
work with auto-auto-auto-generator :)
- this patch is weird as it includes 3 different implementations of
dir_config, dir_config_old, dir_config_xs - please pick the right one.
the test actually tests only dir_config, but they all should work.
- perl_get_startup_server() from 1.x, I couldn't find it in 2.x (probably
it's not implemented yet, so it's in the comment XXX)
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/27 17:15:34
@@ -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 => 46, todo => [35];
#Apache->request($r); #PerlOptions +GlobalRequest takes care
my $gr = Apache->request;
@@ -86,6 +87,63 @@
#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';
+
+ {
+ 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")});
+ }
+
+ # make this non-todo when the following works:
+ # my @received = $dir_config->get($key)
+ # PerlAddVar ITERATE2 test
+ {
+ my $key = make_key('1');
+ my @received = $dir_config->get($key);
+ my @expected = ("SetValue1", "AddValue1", "AddValue1_1");
+ my $ok = 1;
+ for (0..$#expected) {
+ $ok = 0 unless defined $received[$_]
+ && $expected[$_] eq $received[$_];
+ }
+ ok $ok;
+ }
+
+ # 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 +186,24 @@
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 SetValue1
+PerlAddVar TestAPI__request_rec_Key1 AddValue1 AddValue1_1
+
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/27 17:15:34
@@ -92,4 +92,59 @@
MARK++; \
}
+#define TABLE_GET(table, do_taint) \
+ if (key == NULL) { \
+ RETVAL = table ? modperl_hash_tie(aTHX_ "APR::Table", Nullsv, (void*)table) :
+&PL_sv_undef; \
+ } \
+ else { \
+ char *val; \
+ if (table && (val = (char *)apr_table_get(table, key))) { \
+ RETVAL = newSVpv(val, 0); \
+ } \
+ else { \
+ RETVAL = newSV(0); \
+ } \
+ if (do_taint) { \
+ SvTAINTED_on(RETVAL); \
+ } \
+ }
+
+/* this is the _SET part of TABLE_GET, which can only be run from pure
+ * XS code */
+/* else if (table && (items > 3)) { \ */
+/* if (ST(2) == &PL_sv_undef) { \ */
+/* apr_table_unset(table, key); \ */
+/* } \ */
+/* else { \ */
+/* apr_table_set(table, key, SvPV_nolen(ST(2))); \ */
+/* } \ */
+/* } \ */
+
+#define TABLE_GET_SET(table, do_taint) \
+ if (key == NULL) { \
+ RETVAL = table ? modperl_hash_tie(aTHX_ "APR::Table", Nullsv, (void*)table) :
+&PL_sv_undef; \
+ } \
+ else if (table && (items > 3)) { \
+ 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 (table && (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/27 17:15:34
@@ -176,3 +176,125 @@
return retval;
}
+
+static MP_INLINE
+SV *mpxs_Apache__RequestRec_dir_config_old(request_rec *r, char *key)
+{
+ dTHX; // XXX
+ SV *RETVAL;
+
+ if(r && r->per_dir_config) {
+ MP_dDCFG;
+ TABLE_GET(dcfg->SetVar, FALSE);
+ }
+ if (!SvTRUE(RETVAL)) {
+ server_rec *s;
+
+ // XXX: $s->dir_config in startup.pl may not have server yet started!
+ // server_rec *s = r && r->server ? r->server : perl_get_startup_server();
+ s = r->server;
+
+ if (s && s->module_config) {
+ MP_dSCFG(s);
+ SvREFCNT_dec(RETVAL); /* in case above did newSV(0) */
+ TABLE_GET(scfg->SetVar, FALSE);
+ }
+ else {
+ RETVAL = &PL_sv_undef;
+ }
+ }
+
+ return RETVAL;
+}
+
+static MP_INLINE
+SV *mpxs_Apache__RequestRec_dir_config(request_rec *r, char *key, char *val)
+{
+ dTHX; // XXX
+ SV *RETVAL;
+
+ if(r && r->per_dir_config) {
+ MP_dDCFG;
+ TABLE_GET(dcfg->SetVar, FALSE);
+ }
+ if (!SvTRUE(RETVAL)) {
+ server_rec *s;
+
+ // XXX: $s->dir_config in startup.pl may not have server yet started!
+ // server_rec *s = r && r->server ? r->server : perl_get_startup_server();
+ Perl_warn(aTHX_ "fail: r, try s\n");
+ s = r->server;
+ Perl_warn(aTHX_ "got: s\n");
+
+ if (s && s->module_config) {
+ MP_dSCFG(s);
+ SvREFCNT_dec(RETVAL); /* in case above did newSV(0) */
+ TABLE_GET(scfg->SetVar, FALSE);
+ }
+ else {
+ RETVAL = &PL_sv_undef;
+ }
+ }
+
+ return RETVAL;
+}
+
+static XS(MPXS_Apache__RequestRec_dir_config_xs)
+{
+ dXSARGS;
+ //dTHX; // XXX
+
+ if (items < 1 || items > 3) {
+ Perl_croak(aTHX_ "Usage: Apache::RequestRec::dir_config_xs(r, key=NULL,
+val=NULL)");
+ }
+
+ SP -= items;
+ {
+ char *key;
+ char *val;
+ Apache__RequestRec r = modperl_xs_sv2request_rec(aTHX_ ST(0),
+"Apache::RequestRec", cv);
+ SV *RETVAL;
+
+ if (items < 2)
+ key = NULL;
+ else {
+ key = (char *)SvPV_nolen(ST(1));
+ }
+
+ if (items < 3)
+ val = NULL;
+ else {
+ val = (char *)SvPV_nolen(ST(2));
+ }
+
+ if(r && r->per_dir_config) {
+ MP_dDCFG;
+ TABLE_GET_SET(dcfg->SetVar, FALSE);
+ }
+
+ if (!SvTRUE(RETVAL)) {
+ server_rec *s;
+
+ // XXX: $s->dir_config in startup.pl may not have server yet started!
+ // server_rec *s = r && r->server ? r->server : perl_get_startup_server();
+ Perl_warn(aTHX_ "fail: r, try s\n");
+ s = r->server;
+ Perl_warn(aTHX_ "got: s\n");
+
+ if (s && s->module_config) {
+ MP_dSCFG(s);
+ SvREFCNT_dec(RETVAL); /* in case above did newSV(0) */
+ TABLE_GET(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/27 17:15:34
@@ -11,6 +11,9 @@
mpxs_Apache__RequestRec_no_cache | | r, flag=Nullsv
PACKAGE=Apache::RequestRec
mpxs_Apache__RequestRec_new | | classname, c, base_pool=NULL
+ mpxs_Apache__RequestRec_dir_config | | r, key=NULL, val=NULL
+ mpxs_Apache__RequestRec_dir_config_old | | r, key=NULL
+DEFINE_dir_config_xs | MPXS_Apache__RequestRec_dir_config_xs | ...
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]
