joes 2004/07/11 11:35:26
Modified: glue/perl/t/response/TestApReq request.pm
glue/perl/xsbuilder apreq_xs_tables.h
glue/perl/xsbuilder/Apache/Upload Apache__Upload.h
Log:
Add v-string magic to all table-key generators (sv_setsv only copies v-string
magic) and basic iterator tests to the end of request.pm. We should eventually
move these tests to a separate table.t test script.
Revision Changes Path
1.27 +26 -2 httpd-apreq-2/glue/perl/t/response/TestApReq/request.pm
Index: request.pm
===================================================================
RCS file: /home/cvs/httpd-apreq-2/glue/perl/t/response/TestApReq/request.pm,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- request.pm 11 Jul 2004 06:31:44 -0000 1.26
+++ request.pm 11 Jul 2004 18:35:26 -0000 1.27
@@ -140,11 +140,35 @@
if (ref $@ eq "Apache::Request::Error") {
my $args = [EMAIL PROTECTED]>{_r}->args('test'); # checks _r is
an object ref
my $upload = [EMAIL PROTECTED]>upload('HTTPUPLOAD'); # no
exception this time!
- [EMAIL PROTECTED]>print("ok") if $args eq $test;
+ die "args test failed" unless $args eq $test;
$args = [EMAIL PROTECTED]>args;
$args->add("foo" => "bar1");
$args->add("foo" => "bar2");
- warn "$a => $b" while ($a, $b) = each %$args;
+ my $test_string = "";
+
+ $test_string .= "$a=$b;" while ($a, $b) = each %$args;
+ die "each test failed: '$test_string'" unless
+ $test_string eq "test=disable_uploads;foo=bar1;foo=bar2;";
+
+ $test_string = join ":", values %$args;
+ die "values test failed: $test_string" unless
+ $test_string eq "disable_uploads:bar1:bar2";
+
+ $test_string = "";
+ $test_string .= "$_=" . $args->get($_) . ";" for $args->get;
+ die "get test failed: '$test_string'" unless
+ $test_string eq "test=disable_uploads;foo=bar1;foo=bar2;";
+
+ $test_string = "";
+ $test_string .= "$_=" . $args->get($_) . ";" for @_ = $args->get;
+ die "get test2 failed: '$test_string'" unless
+ $test_string eq "test=disable_uploads;foo=bar1;foo=bar2;";
+
+ $test_string = join ":", %$args;
+ die "list deref test failed: '$test_string'" unless
+ $test_string eq "test:disable_uploads:foo:bar1:foo:bar2";
+
+ [EMAIL PROTECTED]>print("ok");
}
}
1.7 +56 -34 httpd-apreq-2/glue/perl/xsbuilder/apreq_xs_tables.h
Index: apreq_xs_tables.h
===================================================================
RCS file: /home/cvs/httpd-apreq-2/glue/perl/xsbuilder/apreq_xs_tables.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- apreq_xs_tables.h 11 Jul 2004 06:31:44 -0000 1.6
+++ apreq_xs_tables.h 11 Jul 2004 18:35:26 -0000 1.7
@@ -20,7 +20,6 @@
/* backward compatibility macros support */
#include "ppport.h"
-
#define apreq_xs_sv2table(sv) ((apr_table_t *) SvIVX(SvRV(sv)))
#define apreq_xs_table2sv(t,class,parent) \
apreq_xs_table_c2perl(aTHX_ t, env, class, parent)
@@ -90,7 +89,6 @@
/* TABLE_GET */
-
struct apreq_xs_do_arg {
void *env;
SV *parent;
@@ -107,11 +105,11 @@
dSP;
SV *sv = newSVpv(key,0);
-#if WRAP_TABLE_DO_INSTEAD
- SvUPGRADE(sv, SVt_PVMG);
- sv_magic(sv, Nullsv, PERL_MAGIC_ext, Nullch, -1);
- SvMAGIC(sv)->mg_ptr = (void *)apreq_strtoval(val);
-#endif
+
+ sv_magic(sv, Nullsv, PERL_MAGIC_vstring, Nullch, -1);
+ SvMAGIC(sv)->mg_ptr = (char *)val;
+ SvRMAGICAL_on(sv);
+
XPUSHs(sv_2mortal(sv));
PUTBACK;
return 1;
@@ -181,18 +179,18 @@
env = apreq_xs_##attr##_sv2env(obj); \
d.env = env; \
d.parent = obj; \
+ \
if (items == 2) \
key = SvPV_nolen(ST(1)); \
\
XSprePUSH; \
switch (GIMME_V) { \
apreq_##type##_t *RETVAL; \
- \
+ IV idx; \
+ MAGIC *mg; \
case G_ARRAY: \
PUTBACK; \
apreq_xs_##attr##_push(obj, &d, key); \
- if (items == 1) \
- SvCUR(obj) = 0; \
break; \
\
case G_SCALAR: \
@@ -203,16 +201,15 @@
PUTBACK; \
break; \
} \
- else if (SvCUR(obj) > 0) { \
+ else if ((idx = SvCUR(obj)) > 0) { \
const apr_array_header_t *arr = apr_table_elts( \
apreq_xs_##attr##_sv2table(obj)); \
apr_table_entry_t *te = (apr_table_entry_t *)arr->elts; \
\
- if (SvCUR(obj) <= arr->nelts \
- && strcasecmp(key, te[SvCUR(obj)-1].key) == 0) \
+ if (idx <= arr->nelts && !strcasecmp(key, te[idx-1].key)) \
{ \
RETVAL = apreq_value_to_##type( \
- apreq_strtoval(te[SvCUR(obj)-1].val)); \
+ apreq_strtoval(te[idx-1].val)); \
if (COND) { \
XPUSHs(sv_2mortal(apreq_xs_##type##2sv( \
RETVAL,subclass,obj))); \
@@ -221,8 +218,24 @@
} \
} \
} \
+ if (SvMAGICAL(ST(1)) \
+ && (mg = mg_find(ST(1),PERL_MAGIC_vstring)) \
+ && mg->mg_len == -1) \
+ { \
+ RETVAL = apreq_value_to_##type( \
+ apreq_strtoval(mg->mg_ptr)); \
+ if (!strcasecmp(key,RETVAL->v.name) && (COND)) { \
+ XPUSHs(sv_2mortal(apreq_xs_##type##2sv( \
+ RETVAL,subclass,obj))); \
+ PUTBACK; \
+ break; \
+ \
+ } \
+ } \
+ \
\
RETVAL = apreq_xs_##attr##_##type(obj, key); \
+ \
if (RETVAL && (COND)) \
XPUSHs(sv_2mortal( \
apreq_xs_##type##2sv(RETVAL,subclass,obj))); \
@@ -233,26 +246,35 @@
apreq_xs_##attr##_error_check; \
}
-#define APREQ_XS_DEFINE_TABLE_NEXTKEY(attr) \
-static XS(apreq_xs_##attr##_NEXTKEY) \
-{ \
- dXSARGS; \
- SV *obj; \
- if (!SvROK(ST(0))) \
- Perl_croak(aTHX_ "Usage: $table->NEXTKEY($prev)"); \
- obj = apreq_xs_find_obj(aTHX_ ST(0), #attr); \
- const apr_array_header_t *arr = apr_table_elts( \
- apreq_xs_##attr##_sv2table(obj)); \
- apr_table_entry_t *te = (apr_table_entry_t *)arr->elts; \
- \
- if (items == 1) \
- SvCUR(obj) = 0; \
- \
- if (SvCUR(obj) >= arr->nelts) { \
- SvCUR(obj) = 0; \
- XSRETURN_UNDEF; \
- } \
- XSRETURN_PV(te[SvCUR(obj)++].key); \
+#define APREQ_XS_DEFINE_TABLE_NEXTKEY(attr) \
+static XS(apreq_xs_##attr##_NEXTKEY) \
+{ \
+ dXSARGS; \
+ SV *sv, *obj; \
+ IV idx; \
+ const apr_array_header_t *arr; \
+ apr_table_entry_t *te; \
+ \
+ if (!SvROK(ST(0))) \
+ Perl_croak(aTHX_ "Usage: $table->NEXTKEY($prev)"); \
+ obj = apreq_xs_find_obj(aTHX_ ST(0), #attr); \
+ arr = apr_table_elts(apreq_xs_##attr##_sv2table(obj)); \
+ te = (apr_table_entry_t *)arr->elts; \
+ \
+ if (items == 1) \
+ SvCUR(obj) = 0; \
+ \
+ if (SvCUR(obj) >= arr->nelts) { \
+ SvCUR(obj) = 0; \
+ XSRETURN_UNDEF; \
+ } \
+ idx = SvCUR(obj)++; \
+ sv = newSVpv(te[idx].key, 0); \
+ sv_magic(sv, Nullsv, PERL_MAGIC_vstring, Nullch, -1); \
+ SvMAGIC(sv)->mg_ptr = (char *)te[idx].val; \
+ SvRMAGICAL_on(sv); \
+ ST(0) = sv_2mortal(sv); \
+ XSRETURN(1); \
}
1.22 +10 -9
httpd-apreq-2/glue/perl/xsbuilder/Apache/Upload/Apache__Upload.h
Index: Apache__Upload.h
===================================================================
RCS file:
/home/cvs/httpd-apreq-2/glue/perl/xsbuilder/Apache/Upload/Apache__Upload.h,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- Apache__Upload.h 11 Jul 2004 06:31:44 -0000 1.21
+++ Apache__Upload.h 11 Jul 2004 18:35:26 -0000 1.22
@@ -87,19 +87,20 @@
#endif
dSP;
+ SV *sv;
- if (key) {
- if (val && apreq_value_to_param(apreq_strtoval(val))->bb)
- XPUSHs(sv_2mortal(newSVpv(key,0)));
- else /* not an upload, so skip it */
- return 1;
- }
- else
- XPUSHs(&PL_sv_undef);
+ if (apreq_value_to_param(apreq_strtoval(val))->bb = NULL)
+ return 1;
+ sv = newSVpv(key,0);
+
+ sv_magic(sv, Nullsv, PERL_MAGIC_vstring, Nullch, -1);
+ SvMAGIC(sv)->mg_ptr = (char *)val;
+ SvRMAGICAL_on(sv);
+
+ XPUSHs(sv_2mortal(sv));
PUTBACK;
return 1;
-
}
