After a fun week of machines crashing all over me, here is my first attempt at
a tied implementation of APR::Tables.
Important to note that this will most probably be partly rewritten as I don't believe
it's "the right way" to do it. It does work for me though.
The few things that I believe are not done right are:
1. the tie and untie functions should be macros
2. the T_APRTABLEOBJ typemap stuff is just nasty. The only thing I want to be able
to do
is to define input/output typemap for an APR::Table, and right now I had to
hardcode quite
a few things
3. All the mp_xs_sv2_* macros are completely separate from the typemap entries, and I
think they
should be somehow tied together. Right now I have to
#define mp_xs_sv2_APR__Table(sv) \
_mpxs_apr_table_untie(aTHX_ sv)
if I want to use mpxs_usage_va_2 and friends
4. XS aliases. if apr_table_get and apr_table_FETCH are identical, there should be a
way to simply
alias one to the other instead of duplicating the XS glue
newXS("APR::Table::FETCH", XS_APR__Table_get, file);
is all that's required.
5. FIRSTKEY, NEXTKEY not implemented yet, as I have to figure out a place I can stash
the state of an iterator somwehere.
Somehow I believe these issues are probably already supported by the code generation
stuff, just couldn't find
it at all. Care to point me in the right direction ?
--
Philippe M. Chiasson <[EMAIL PROTECTED]>
Extropia's Resident System Guru
http://www.eXtropia.com/
You can solve any problem by adding a level of
indirection--except the problem of having too many levels
of indirection.
-- Larry Wall
perl -e '$$=\${gozer};{$_=unpack(P26,pack(L,$$));/^Just Another Perl
Hacker!\n$/&&print||$$++&&redo}'
Index: lib/ModPerl/WrapXS.pm
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/lib/ModPerl/WrapXS.pm,v
retrieving revision 1.21
diff -u -I'$Id' -I'$Revision' -r1.21 WrapXS.pm
--- lib/ModPerl/WrapXS.pm 2001/09/13 02:37:37 1.21
+++ lib/ModPerl/WrapXS.pm 2001/09/20 04:52:24
@@ -506,6 +506,7 @@
my %typemap = (
'Apache::RequestRec' => 'T_APACHEOBJ',
'apr_time_t' => 'T_APR_TIME',
+ 'APR::Table' => 'T_APRTABLEOBJ',
);
sub write_typemap {
Index: t/response/TestAPR/table.pm
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/t/response/TestAPR/table.pm,v
retrieving revision 1.2
diff -u -I'$Id' -I'$Revision' -r1.2 table.pm
--- t/response/TestAPR/table.pm 2001/09/15 18:17:31 1.2
+++ t/response/TestAPR/table.pm 2001/09/20 04:52:24
@@ -14,7 +14,7 @@
sub handler {
my $r = shift;
- plan $r, tests => 9;
+ plan $r, tests => 15;
my $table = APR::Table::make($r->pool, 16);
@@ -58,7 +58,24 @@
$filter_count = 0;
$table->do("my_filter", "c", "b", "e");
ok $filter_count == 3;
+
+ #Tied interface
+ {
+ my $table = APR::Table::make($r->pool, $TABLE_SIZE);
+
+ ok (UNIVERSAL::isa($table, 'HASH'));
+
+ ok (UNIVERSAL::isa($table, 'HASH')) && tied(%$table);
+
+ ok $table->{'foo'} = 'bar';
+ ok $table->{'foo'} eq 'bar';
+
+ ok delete $table->{'foo'} || 1;
+
+ ok not exists $table->{'foo'};
+ }
+
Apache::OK;
}
Index: todo/api.txt
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/todo/api.txt,v
retrieving revision 1.4
diff -u -I'$Id' -I'$Revision' -r1.4 api.txt
--- todo/api.txt 2001/09/15 18:17:31 1.4
+++ todo/api.txt 2001/09/20 04:52:24
@@ -5,7 +5,8 @@
tied filehandle interface:
-CLOSE, GETC, PRINTF, READLINE
-APR::Table tie mechanism:
+APR::Table FIRSTKEY/NEXTKEY
+
$r->headers_out->{KEY} is not currently supported
might want to make this optional, disabled by default
Index: xs/typemap
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/xs/typemap,v
retrieving revision 1.4
diff -u -I'$Id' -I'$Revision' -r1.4 typemap
--- xs/typemap 2001/05/04 21:21:49 1.4
+++ xs/typemap 2001/09/20 04:52:25
@@ -8,6 +8,9 @@
T_APACHEOBJ
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+T_APRTABLEOBJ
+ $arg = _mpxs_apr_table_tie(aTHX_ $arg, $var);
+
T_VPTR
sv_setiv($arg, PTR2IV($var));
@@ -18,6 +21,9 @@
INPUT
T_APACHEOBJ
$var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
+
+T_APRTABLEOBJ
+ $var = _mpxs_apr_table_untie(aTHX_ $arg);
T_APACHEREF
$var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
Index: xs/APR/Table/APR__Table.h
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/xs/APR/Table/APR__Table.h,v
retrieving revision 1.3
diff -u -I'$Id' -I'$Revision' -r1.3 APR__Table.h
--- xs/APR/Table/APR__Table.h 2001/09/19 23:08:07 1.3
+++ xs/APR/Table/APR__Table.h 2001/09/20 04:52:25
@@ -1,3 +1,10 @@
+#define mp_xs_sv2_APR__Table(sv) \
+_mpxs_apr_table_untie(aTHX_ sv)
+
+#define apr_table_FETCH apr_table_get
+#define apr_table_STORE apr_table_set
+#define apr_table_DELETE apr_table_unset
+
typedef struct {
SV *cv;
apr_hash_t *filter;
@@ -6,6 +13,9 @@
typedef int (*mpxs_apr_table_do_cb_t)(void *, const char *, const char *);
+SV* _mpxs_apr_table_tie(pTHX_ SV *, apr_table_t *);
+apr_table_t *_mpxs_apr_table_untie(pTHX_ SV *);
+
static int mpxs_apr_table_do_cb(void *data,
const char *key, const char *val)
{
@@ -84,4 +94,53 @@
/* Free tdata.filter or wait for the pool to go away? */
return;
+}
+
+static
+SV* _mpxs_apr_table_tie(pTHX_ SV *sv, apr_table_t *t)
+{
+ SV *hv = (SV*) newHV();
+ sv_setref_pv(sv,"APR::Table",t);
+ sv_magic(hv, sv, PERL_MAGIC_tied, Nullch, 0);
+ return SvREFCNT_inc(sv_bless(sv_2mortal(newRV_noinc(hv)),gv_stashpv("APR::Table",
+TRUE)));
+}
+
+static
+apr_table_t *_mpxs_apr_table_untie(pTHX_ SV *sv)
+{
+ if (sv_derived_from(sv, "APR::Table")) {
+ if( SVt_PVHV == SvTYPE(SvRV(sv)) )
+ {
+ SV *hv = SvRV(sv);
+ MAGIC *mg;
+
+ if (SvMAGICAL(hv)) {
+ if (mg = mg_find(hv, PERL_MAGIC_tied)) {
+ return (apr_table_t *)SvIV((SV*)SvRV(mg->mg_obj));
+ } else
+ {
+ Perl_warn(aTHX_ "Wrong Magick: (%c)\n", mg);
+ }
+
+ } else
+ {
+ Perl_warn(aTHX_ "Not Magick but should\n");
+ }
+
+ } else
+ {
+ return (apr_table_t *) SvIV((SV*)SvRV(sv));
+ }
+ } else
+ {
+ Perl_croak(aTHX_ "argument is not a blessed reference (expecting an
+APR::Table derived object)");
+ }
+
+ return NULL;
+}
+
+static MP_INLINE
+int apr_table_EXISTS(apr_table_t *t, const char *key)
+{
+ return (NULL==apr_table_get(t,key)) ? 0 : 1;
}
Index: xs/maps/apr_functions.map
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/xs/maps/apr_functions.map,v
retrieving revision 1.21
diff -u -I'$Id' -I'$Revision' -r1.21 apr_functions.map
--- xs/maps/apr_functions.map 2001/09/17 01:06:08 1.21
+++ xs/maps/apr_functions.map 2001/09/20 04:52:25
@@ -191,7 +191,15 @@
-apr_table_setn
apr_table_unset
-apr_table_vdo
-
+ apr_table_FETCH
+ apr_table_STORE
+ apr_table_DELETE
+ apr_table_CLEAR
+ apr_table_EXISTS
+-apr_table_KEYS
+-apr_table_FIRSTKEY
+-apr_table_NEXTKEY
+
!MODULE=APR::File
-apr_file_open
-apr_file_close
PGP signature
