Author: joes Date: Tue Apr 19 10:25:39 2005 New Revision: 161925 URL: http://svn.apache.org/viewcvs?view=rev&rev=161925 Log: Remove crufty XS macros.
Modified:
httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_postperl.h
httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_tables.h
Modified: httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_postperl.h
URL:
http://svn.apache.org/viewcvs/httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_postperl.h?view=diff&r1=161924&r2=161925
==============================================================================
--- httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_postperl.h (original)
+++ httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_postperl.h Tue Apr 19
10:25:39 2005
@@ -94,31 +94,6 @@
/* conversion function templates based on modperl-2's sv2request_rec */
-/**
- * Searches a perl object ref with apreq_xs_find_obj
- * and produces a pointer to the object's C analog.
- */
-APR_INLINE
-static void *apreq_xs_perl2c(pTHX_ SV* in, const char name)
-{
- SV *sv = apreq_xs_find_obj(aTHX_ in, name);
- IV iv = SvIVX(SvRV(sv));
- return INT2PTR(void *, iv);
-}
-
-APR_INLINE
-static SV *apreq_xs_perl_sv2env(pTHX_ SV *sv)
-{
- MAGIC *mg;
- if ((mg = mg_find(sv, PERL_MAGIC_ext)))
- return mg->mg_obj;
-
- Perl_croak(aTHX_ "Can't find magic environment");
- return NULL; /* not reached */
-}
-
-
-
static APR_INLINE
SV *apreq_xs_object2sv(pTHX_ void *ptr, const char *class, SV *parent, const
char *base)
{
@@ -244,153 +219,6 @@
IV iv = SvIVX(obj);
return INT2PTR(apreq_cookie_t *, iv);
}
-
-
-
-/**
- * Searches a perl object ref with apreq_xs_find_obj
- * and produces a pointer to the underlying C environment.
- */
-
-/**
- * Converts a C object, with environment, to a Perl object.
- * @param obj C object.
- * @param env C environment.
- * @param class Class perl object will be blessed into.
- * @param parent XXX
- * @return Reference to the new Perl object in class.
- */
-APR_INLINE
-static SV *apreq_xs_c2perl(pTHX_ void *obj, void *env, const char *class, SV
*parent)
-{
- SV *rv = sv_setref_pv(newSV(0), class, obj);
- if (env) {
- /* We use the old idiom for sv_magic() below,
- * because perl 5.6 mangles the env pointer on
- * the recommended 5.8.x invocation
- *
- * sv_magic(SvRV(rv), Nullsv, PERL_MAGIC_ext, env, 0);
- *
- * 5.8.x is OK with the old way as well, but in the future
- * we may have to use "#if PERL_VERSION < 8" ...
- */
- sv_magic(SvRV(rv), parent, PERL_MAGIC_ext, Nullch, -1);
- SvMAGIC(SvRV(rv))->mg_ptr = env;
- }
- return rv;
-}
-
-#define apreq_xs_2sv(t,class,parent) \
- apreq_xs_c2perl(aTHX_ t, env, class, parent)
-
-#define apreq_xs_sv2(type,sv)((apreq_##type##_t *) \
- apreq_xs_perl2c(aTHX_ sv, #type))
-
-#define apreq_xs_sv2env(sv) ((void *)SvIVX((apreq_xs_perl_sv2env(aTHX_ sv))))
-
-/** Converts apreq_env to a Perl package, which forms the
- * base class for Apache::Request and Apache::Cookie::Jar objects.
- */
-#define APREQ_XS_DEFINE_ENV(type) \
-static XS(apreq_xs_##type##_env) \
-{ \
- char *class = NULL; \
- dXSARGS; \
- SV *sv, *obj; \
- /* map environment to package */ \
- if (items != 1) \
- Perl_croak(aTHX_ "Usage: $obj->env"); \
- \
- if (strcmp(apreq_env_name, "APACHE2") == 0) \
- class = "Apache::RequestRec"; \
- else if (strcmp(apreq_env_name, "CGI") == 0) \
- class = "APR::Pool"; \
- \
- /* else if ... add more conditionals here as \
- additional environments become supported */ \
- \
- if (class == NULL) \
- XSRETURN(0); \
- \
- XSprePUSH; \
- if (SvROK(ST(0))) { \
- obj = apreq_xs_find_obj(aTHX_ ST(0), #type); \
- sv = apreq_xs_perl_sv2env(aTHX_ obj); \
- XPUSHs(sv_2mortal(newRV_inc(sv))); \
- } \
- else \
- XPUSHs(sv_2mortal(newSVpv(class, 0))); \
- \
- XSRETURN(1); \
-}
-
-
-
-#define APREQ_XS_DEFINE_CONFIG(attr) \
-static XS(apreq_xs_##attr##_config) \
-{ \
- dXSARGS; \
- SV *sv, *obj; \
- int j; \
- \
- if (items % 2 != 1 || !SvROK(ST(0))) \
- Perl_croak(aTHX_ "usage: $obj->config(%settings)"); \
- \
- sv = ST(0); \
- obj = apreq_xs_find_obj(aTHX_ sv, #attr); \
- \
- for (j = 1; j + 1 < items; j += 2) { \
- STRLEN alen; \
- const char *attr = SvPVbyte(ST(j),alen); \
- \
- if (strcasecmp(attr,"VALUE_CLASS") == 0) \
- { \
- STRLEN vlen; \
- const char *val = SvPV(ST(j+1), vlen); \
- MAGIC *mg = mg_find(obj, PERL_MAGIC_ext); \
- \
- if (mg->mg_len > 0) { \
- Safefree(mg->mg_ptr); \
- } \
- mg->mg_ptr = savepvn(val, vlen); \
- mg->mg_len = vlen; \
- \
- } \
- else { \
- Perl_warn(aTHX_ "$obj->config(%settings): " \
- "Unrecognized attribute %s, skipped", attr); \
- } \
- } \
- \
- XSRETURN(0); \
-}
-
-
-/** requires definition of apreq_xs_##type##2sv(t,class,parent) macro */
-
-#define APREQ_XS_DEFINE_MAKE(type) \
-static XS(apreq_xs_make_##type) \
-{ \
- dXSARGS; \
- void *env; \
- apr_pool_t *pool; \
- const char *key, *val, *class; \
- STRLEN klen, vlen; \
- apreq_##type##_t *t; \
- \
- if (items != 4 || SvROK(ST(0)) || !SvROK(ST(1))) \
- Perl_croak(aTHX_ "Usage: $class->make($env, $name, $val)"); \
- \
- class = SvPV_nolen(ST(0)); \
- env = (void *)SvIVX(SvRV(ST(1))); \
- pool = apreq_env_pool(env); \
- key = SvPVbyte(ST(2), klen); \
- val = SvPVbyte(ST(3), vlen); \
- t = apreq_make_##type(pool, key, klen, val, vlen); \
- XSprePUSH; \
- XPUSHs(sv_2mortal(apreq_xs_##type##2sv(t,class,SvRV(ST(1))))); \
- XSRETURN(1); \
-}
static APR_INLINE
void apreq_xs_croak(pTHX_ HV *data, apr_status_t rc, const char *func,
Modified: httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_tables.h
URL:
http://svn.apache.org/viewcvs/httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_tables.h?view=diff&r1=161924&r2=161925
==============================================================================
--- httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_tables.h (original)
+++ httpd/apreq/trunk/glue/perl/xsbuilder/apreq_xs_tables.h Tue Apr 19 10:25:39
2005
@@ -21,377 +21,11 @@
#include "ppport.h"
-/**
- * Converts a C object, with environment, to a TIEHASH object.
- * @param obj C object.
- * @param env C environment.
- * @param class Class perl object will be blessed and tied to.
- * @return Reference to a new TIEHASH object in class.
- */
-
-
-
-/*#define apreq_xs_sv2table(sv) ((apr_table_t *) SvIVX(SvRV(sv)))
- *#define apreq_xs_table2sv(t,class,parent,name,nlen,tainted) \
- * apreq_xs_table_c2perl(aTHX_ t, name, nlen, class, parent, tainted)
- */
-
-#define APREQ_XS_DEFINE_TABLE_MAKE(attr,pkg, plen) \
-static XS(apreq_xs_table_##attr##_make) \
-{ \
- \
- dXSARGS; \
- SV *sv, *parent; \
- void *env; \
- const char *class; \
- apr_table_t *t; \
- \
- if (items != 2 || !SvPOK(ST(0)) || !SvROK(ST(1))) \
- Perl_croak(aTHX_ "Usage: $class->make($env)"); \
- \
- \
- class = SvPV_nolen(ST(0)); \
- parent = SvRV(ST(1)); \
- env = (void *)SvIVX(parent); \
- t = apr_table_make(apreq_env_pool(env), APREQ_NELTS); \
- sv = apreq_xs_table2sv(t, class, parent, pkg, plen, SvTAINTED(parent)); \
- XSprePUSH; \
- PUSHs(sv); \
- XSRETURN(1); \
-}
-
-#define APREQ_XS_DEFINE_TABLE_METHOD_N(attr,method) \
-static XS(apreq_xs_table_##attr##_##method) \
-{ \
- dXSARGS; \
- void *env; \
- apr_table_t *t; \
- const char *key, *val; \
- SV *sv, *obj; \
- STRLEN klen, vlen; \
- apreq_##attr##_t *RETVAL = NULL; \
- \
- switch (items) { \
- case 2: \
- case 3: \
- if (!SvROK(ST(0))) \
- break; \
- sv = ST(0); \
- obj = apreq_xs_find_obj(aTHX_ sv, #attr); \
- env = apreq_xs_sv2env(obj); \
- t = (apr_table_t *)SvIVX(obj); \
- \
- if (SvROK(ST(items-1))) { \
- RETVAL = (apreq_##attr##_t *)SvIVX(SvRV(ST(items-1))); \
- if (SvTAINTED(SvRV(ST(items-1)))) \
- SvTAINTED_on(obj); \
- } \
- else if (items == 3) { \
- key = SvPV(ST(1),klen); \
- val = SvPV(ST(2),vlen); \
- RETVAL = apreq_make_##attr(apreq_env_pool(env), key, klen, \
- val, vlen); \
- if (SvTAINTED(ST(1)) || SvTAINTED(ST(2))) \
- SvTAINTED_on(obj); \
- } \
- apr_table_##method##n(t, RETVAL->v.name, RETVAL->v.data); \
- XSRETURN_EMPTY; \
- default: \
- ; /* usage */ \
- } \
- \
- Perl_croak(aTHX_ "Usage: $table->" #method \
- "([$key,] $val))"); \
-}
-
-
-
struct apreq_xs_do_arg {
const char *pkg;
SV *parent,
*sub;
PerlInterpreter *perl;
};
-
-
-#define apreq_xs_do(attr) (items == 1 ? apreq_xs_table_keys \
- : apreq_xs_##attr##_table_values)
-
-#define apreq_xs_push(attr,sv,d,key) do { \
- apr_table_t *t = apreq_xs_##attr##_sv2table(sv); \
- if (t != NULL) { \
- if (items == 1) { \
- t = apr_table_copy(apreq_env_pool(env), t); \
- apr_table_compress(t, APR_OVERLAP_TABLES_SET); \
- apr_table_do(apreq_xs_table_keys, d, t, NULL); \
- } \
- else \
- apr_table_do(apreq_xs_##attr##_table_values, d, \
- t, key, NULL); \
- } \
-} while (0)
-
-/**
- * @param attr obj/attribute name.
- * @param class perl class the attribute is in (usually a table class).
- * @param type apreq data type: param or cookie.
- * @param subclass perl class for returned "type2sv" scalars.
- * @param COND expression that must be true for RETVAL to be added
- * to the return list.
- *
- * @remark
- * Requires macros for controlling behavior in context:
- *
- * apreq_xs_##attr##_push G_ARRAY
- * apreq_xs_##attr##_sv2table G_SCALAR (items==1)
- * apreq_xs_##attr##_##type G_SCALAR (items==2)
- * apreq_xs_##type##2sv G_ARRAY and G_SCALAR
- *
- */
-
-#define APREQ_XS_DEFINE_TABLE_GET(attr, class, type, subclass, COND) \
-static int apreq_xs_##attr##_table_values(void *data, const char *key, \
- const char *val) \
-{ \
- struct apreq_xs_do_arg *d = (struct apreq_xs_do_arg *)data; \
- void *env; \
- dTHXa(d->perl); \
- dSP; \
- env = d->env; \
- if (val) { \
- apreq_##type##_t *RETVAL = \
- apreq_value_to_##type(apreq_strtoval(val)); \
- if (COND) { \
- SV *sv = apreq_xs_##type##2sv(RETVAL,d->pkg,d->parent); \
- if (d->tainted) \
- SvTAINTED_on(SvROK(sv)? SvRV(sv) : sv); \
- XPUSHs(sv_2mortal(sv)); \
- } \
- } else \
- XPUSHs(&PL_sv_undef); \
- \
- PUTBACK; \
- return 1; \
-} \
- \
-static XS(apreq_xs_##attr##_get) \
-{ \
- dXSARGS; \
- const char *key = NULL; \
- struct apreq_xs_do_arg d = { NULL, NULL, NULL, NULL, 0, aTHX }; \
- void *env; \
- SV *sv, *obj; \
- MAGIC *mg; \
- if (items == 0 || items > 2 || !SvROK(ST(0))) \
- Perl_croak(aTHX_ "Usage: $object->get($key)"); \
- \
- sv = ST(0); \
- obj = apreq_xs_find_obj(aTHX_ sv, #attr); \
- mg = mg_find(obj, PERL_MAGIC_ext); \
- d.parent = mg->mg_obj; \
- d.pkg = mg->mg_len > 0 ? mg->mg_ptr : subclass; \
- env = (void *)SvIVX(d.parent); \
- d.env = env; \
- \
- d.tainted = SvTAINTED(obj); \
- if (items == 2) \
- key = SvPV_nolen(ST(1)); \
- \
- XSprePUSH; \
- switch (GIMME_V) { \
- apreq_##type##_t *RETVAL; \
- \
- case G_ARRAY: \
- PUTBACK; \
- apreq_xs_##attr##_push(obj, &d, key); \
- break; \
- \
- case G_SCALAR: \
- if (items == 1) { \
- apr_table_t *t = apreq_xs_##attr##_sv2table(obj); \
- if (t != NULL) { \
- SV *tsv = apreq_xs_table2sv(t, class, d.parent, \
- d.pkg, d.pkg ? strlen(d.pkg) : 0, d.tainted); \
- PUSHs(sv_2mortal(tsv)); \
- } \
- PUTBACK; \
- break; \
- } \
- \
- RETVAL = apreq_xs_##attr##_##type(obj, key); \
- \
- if (RETVAL && (COND)) { \
- SV *ssv = apreq_xs_##type##2sv(RETVAL, d.pkg, d.parent); \
- if (d.tainted) \
- SvTAINTED_on(ssv); \
- PUSHs(sv_2mortal(ssv)); \
- } \
- \
- default: \
- PUTBACK; \
- } \
- apreq_xs_##attr##_error_check; \
-}
-
-#define APREQ_XS_DEFINE_TABLE_FETCH(attr,type,subclass) \
-static XS(apreq_xs_##attr##_FETCH) \
-{ \
- dXSARGS; \
- SV *sv, *obj, *parent; \
- IV idx; \
- MAGIC *mg; \
- const char *key, *pkg; \
- const char *val; \
- apr_table_t *t; \
- const apr_array_header_t *arr; \
- apr_table_entry_t *te; \
- void *env; \
- \
- if (items != 2 || !SvROK(ST(0)) || !SvOK(ST(1))) \
- Perl_croak(aTHX_ "Usage: $table->FETCH($key)"); \
- \
- sv = ST(0); \
- obj = apreq_xs_find_obj(aTHX_ sv, #attr); \
- mg = mg_find(obj, PERL_MAGIC_ext); \
- parent = mg->mg_obj; \
- pkg = mg->mg_len > 0 ? mg->mg_ptr : subclass; \
- key = SvPV_nolen(ST(1)); \
- idx = SvCUR(obj); \
- t = apreq_xs_##attr##_sv2table(obj); \
- arr = apr_table_elts(t); \
- te = (apr_table_entry_t *)arr->elts; \
- env = apreq_xs_##attr##_sv2env(obj); \
- \
- if (idx > 0 && idx <= arr->nelts \
- && !strcasecmp(key, te[idx-1].key)) \
- val = te[idx-1].val; \
- else \
- val = apr_table_get(t, key); \
- \
- if (val != NULL) { \
- apreq_##type##_t *RETVAL = apreq_value_to_##type( \
- apreq_strtoval(val)); \
- sv = apreq_xs_##type##2sv(RETVAL, pkg, parent); \
- if (SvTAINTED(obj)) \
- SvTAINTED_on(sv); \
- ST(0) = sv_2mortal(sv); \
- XSRETURN(1); \
- } \
- else \
- XSRETURN_UNDEF; \
-}
-
-
-#define APREQ_XS_DEFINE_TABLE_NEXTKEY(attr) \
-static XS(apreq_xs_##attr##_NEXTKEY) \
-{ \
- dXSARGS; \
- SV *sv, *obj; \
- IV idx; \
- apr_table_t *t; \
- 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); \
- t = apreq_xs_##attr##_sv2table(obj); \
- arr = apr_table_elts(t); \
- 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); \
- if (SvTAINTED(obj)) \
- SvTAINTED_on(sv); \
- ST(0) = sv_2mortal(sv); \
- XSRETURN(1); \
-}
-
-
-#define APREQ_XS_DEFINE_TABLE_DO(attr,type,subclass) \
-static int apreq_xs_##attr##_do_sub(void *data, const char *key, \
- const char *val) \
-{ \
- struct apreq_xs_do_arg *d = data; \
- apreq_##type##_t *RETVAL = apreq_value_to_##type( \
- apreq_strtoval(val)); \
- dTHXa(d->perl); \
- dSP; \
- SV *sv; \
- void *env; \
- int rv; \
- \
- env = d->env; \
- \
- ENTER; \
- SAVETMPS; \
- \
- PUSHMARK(SP); \
- EXTEND(SP,2); \
- \
- sv = newSVpv(key, 0); \
- if (d->tainted) \
- SvTAINTED_on(sv); \
- PUSHs(sv_2mortal(sv)); \
- \
- sv = apreq_xs_##type##2sv(RETVAL, d->pkg, d->parent); \
- if (d->tainted) \
- SvTAINTED_on(sv); \
- PUSHs(sv_2mortal(sv)); \
- \
- PUTBACK; \
- rv = call_sv(d->sub, G_SCALAR); \
- SPAGAIN; \
- rv = (1 == rv) ? POPi : 1; \
- PUTBACK; \
- FREETMPS; \
- LEAVE; \
- \
- return rv; \
-} \
- \
-static XS(apreq_xs_##attr##_do) \
-{ \
- dXSARGS; \
- struct apreq_xs_do_arg d = { NULL, NULL, NULL, NULL, 0, aTHX }; \
- apr_table_t *t; \
- void *env; \
- int i, rv = 1; \
- SV *sv, *obj; \
- MAGIC *mg; \
- \
- if (items < 2 || !SvROK(ST(0)) || !SvROK(ST(1))) \
- Perl_croak(aTHX_ "Usage: $object->do(\\&callback, @keys)"); \
- sv = ST(0); \
- obj = apreq_xs_find_obj(aTHX_ sv, #attr); \
- env = apreq_xs_##attr##_sv2env(obj); \
- t = apreq_xs_##attr##_sv2table(obj); \
- mg = mg_find(obj, PERL_MAGIC_ext); \
- d.parent = mg->mg_obj; \
- d.pkg = mg->mg_len > 0 ? mg->mg_ptr : subclass; \
- d.env = env; \
- d.sub = ST(1); \
- d.tainted = SvTAINTED(obj); \
- if (items == 2) { \
- rv = apr_table_do(apreq_xs_##attr##_do_sub, &d, t, NULL); \
- XSRETURN_IV(rv); \
- } \
- \
- for (i = 2; i < items; ++i) { \
- const char *key = SvPV_nolen(ST(i)); \
- rv = apr_table_do(apreq_xs_##attr##_do_sub, &d, t, key, NULL); \
- if (rv == 0) \
- break; \
- } \
- XSRETURN_IV(rv); \
-}
-
#endif /* APREQ_XS_TABLES_H */
