Here is my second attempt at implementing an TIEHASH interface for APR::Table
It is now complete according to the Tied hash interface and make test passes
without any warning ;-)
There aren't a lot of outstanding issues about this patch, except:
1. I am not sure where to put mpxs_typemap_(in/out)put_APR__Table... right
now I placed them in modperl_util.[ch] as other people will need it.
2. I still have to define this:
#define mp_xs_sv2_APR__Table(sv) mpxs_typemap_input_APR__Table(aTHX_ sv, NULL)
And I can forsee problems if other modules start playing with tables in the
'standard' way using mpxs_usage_va*, as it will revert back to it's default
behaviour and things will start to break ;-(
3. I can't generate the xs/tables/current/*.pm since source_scan seems to be broken
now...
That's all I can think of for now, and I love how all of a sudden
$r->headers_out->{KEY}
suddently works. Didn't add test for them though... should I ?
This time I also spent quite some time fiddling with gnu-indent and all it's millions
of options to try and proprely indent the whole thing. I think I might have succeded
this time, and if I did, I will share my indent receipe (still needed manual fixing
a couple of times)
Let me know if this works for anybody but me.
--
+----------------------------------------------------+
| Philippe M. Chiasson <[EMAIL PROTECTED]> |
+----------------------------------------------------+
| F9BF E0C2 480E 7680 1AE5 3631 CB32 A107 88C3 A5A5 |
+----------------------------------------------------+
gethostent not implemented : Your C library apparently
doesn't implement gethostent(), probably because if it did,
it'd feel morally obligated to return every hostname on the
Internet.
-- perldiag(1)
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 -U5 -b -B -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/19 07:01:49
@@ -504,10 +504,11 @@
}
my %typemap = (
'Apache::RequestRec' => 'T_APACHEOBJ',
'apr_time_t' => 'T_APR_TIME',
+ 'APR::Table' => 'T_APRTABLEOBJ',
);
sub write_typemap {
my $self = shift;
my $typemap = $self->typemap;
Index: src/modules/perl/modperl_perl_includes.h
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/src/modules/perl/modperl_perl_includes.h,v
retrieving revision 1.4
diff -u -U5 -b -B -I'$Id' -I'$Revision' -r1.4 modperl_perl_includes.h
--- src/modules/perl/modperl_perl_includes.h 2001/03/15 01:26:18 1.4
+++ src/modules/perl/modperl_perl_includes.h 2001/09/23 11:37:01
@@ -41,6 +41,10 @@
#ifndef G_METHOD
# define G_METHOD 64
#endif
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
#endif /* MODPERL_PERL_INCLUDES_H */
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/src/modules/perl/modperl_util.c,v
retrieving revision 1.17
diff -u -U5 -b -B -I'$Id' -I'$Revision' -r1.17 modperl_util.c
--- src/modules/perl/modperl_util.c 2001/08/08 16:20:32 1.17
+++ src/modules/perl/modperl_util.c 2001/09/23 14:11:59
@@ -337,5 +337,51 @@
modperl_uri_t *uri = (modperl_uri_t *)apr_pcalloc(p, sizeof(*uri));
uri->pool = p;
return uri;
}
+MP_INLINE SV *mpxs_typemap_output_APR__Table(pTHX_ SV *sv,
+ apr_table_t *t)
+{
+ SV *hv = (SV *)newHV();
+ SV *rsv = newSViv(0);
+
+ sv_setref_pv(rsv, "APR::Table", t);
+ sv_magic(hv, rsv, PERL_MAGIC_tied, Nullch, 0);
+ return SvREFCNT_inc(sv_bless
+ (sv_2mortal(newRV_noinc(hv)),
+ gv_stashpv("APR::Table", TRUE)));
+}
+
+MP_INLINE apr_table_t *mpxs_typemap_input_APR__Table(pTHX_ SV *sv,
+ apr_table_t *t)
+{
+ 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;
+}
Index: src/modules/perl/modperl_util.h
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/src/modules/perl/modperl_util.h,v
retrieving revision 1.16
diff -u -U5 -b -B -I'$Id' -I'$Revision' -r1.16 modperl_util.h
--- src/modules/perl/modperl_util.h 2001/08/08 07:02:41 1.16
+++ src/modules/perl/modperl_util.h 2001/09/23 12:53:01
@@ -48,6 +48,9 @@
modperl_cleanup_data_t *modperl_cleanup_data_new(apr_pool_t *p, void *data);
MP_INLINE modperl_uri_t *modperl_uri_new(apr_pool_t *p);
+MP_INLINE SV *mpxs_typemap_output_APR__Table(pTHX_ SV *, apr_table_t *);
+MP_INLINE apr_table_t *mpxs_typemap_input_APR__Table(pTHX_ SV *, apr_table_t *);
+
#endif /* MODPERL_UTIL_H */
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 -U5 -b -B -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/23 13:58:30
@@ -12,13 +12,13 @@
my $TABLE_SIZE = 20;
sub handler {
my $r = shift;
- plan $r, tests => 9;
+ plan $r, tests => 16;
- my $table = APR::Table::make($r->pool, 16);
+ my $table = APR::Table::make($r->pool, $TABLE_SIZE);
ok (UNIVERSAL::isa($table, 'APR::Table'));
ok $table->set('foo','bar') || 1;
@@ -57,10 +57,39 @@
$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'};
+
+ for (1..$TABLE_SIZE) {
+ $table->{chr($_+97)} = $_ ;
+ }
+
+ $filter_count = 0;
+
+ foreach my $key (sort keys %$table)
+ {
+ my_filter($key,$table->{$key});
+ }
+ ok $filter_count == $TABLE_SIZE;
+ }
+
Apache::OK;
}
sub my_filter {
my ($key,$value) = @_;
Index: todo/api.txt
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/todo/api.txt,v
retrieving revision 1.4
diff -u -U5 -b -B -I'$Id' -I'$Revision' -r1.4 api.txt
--- todo/api.txt 2001/09/15 18:17:31 1.4
+++ todo/api.txt 2001/09/23 13:56:48
@@ -3,14 +3,10 @@
------------------------------------------
tied filehandle interface:
-CLOSE, GETC, PRINTF, READLINE
-APR::Table tie mechanism:
-$r->headers_out->{KEY} is not currently supported
-might want to make this optional, disabled by default
-
$r->finfo:
need apr_finfo_t <-> struct stat conversion (might already be there,
haven't looked close enough yet)
$r->header_{in,out}:
Index: xs/modperl_xs_util.h
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/xs/modperl_xs_util.h,v
retrieving revision 1.8
diff -u -U5 -b -B -I'$Id' -I'$Revision' -r1.8 modperl_xs_util.h
Index: xs/typemap
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/xs/typemap,v
retrieving revision 1.4
diff -u -U5 -b -B -I'$Id' -I'$Revision' -r1.4 typemap
--- xs/typemap 2001/05/04 21:21:49 1.4
+++ xs/typemap 2001/09/23 08:52:18
@@ -6,20 +6,26 @@
######################################################################
OUTPUT
T_APACHEOBJ
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+T_APRTABLEOBJ
+ $arg = mpxs_typemap_output_APR__Table(aTHX_ $arg, $var);
+
T_VPTR
sv_setiv($arg, PTR2IV($var));
T_APR_TIME
sv_setnv($arg, (NV)($var / APR_USEC_PER_SEC));
######################################################################
INPUT
T_APACHEOBJ
$var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
+
+T_APRTABLEOBJ
+ $var = mpxs_typemap_input_APR__Table(aTHX_ $arg, $var)
T_APACHEREF
$var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
T_VPTR
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 -U5 -b -B -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/23 14:13:16
@@ -1,17 +1,24 @@
-typedef struct {
+#define mp_xs_sv2_APR__Table(sv) mpxs_typemap_input_APR__Table(aTHX_ sv, NULL)
+
+#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;
PerlInterpreter *perl;
} mpxs_table_do_cb_data_t;
-typedef int (*mpxs_apr_table_do_cb_t)(void *, const char *, const char *);
+typedef int (*mpxs_apr_table_do_cb_t) (void *, const char *, const char *);
-static int mpxs_apr_table_do_cb(void *data,
- const char *key, const char *val)
+static int mpxs_apr_table_do_cb(void *data, const char *key, const char *val)
{
mpxs_table_do_cb_data_t *tdata = (mpxs_table_do_cb_data_t *)data;
+
dTHXa(tdata->perl);
dSP;
int rv = 0;
/* Skip completely if something is wrong */
@@ -28,12 +35,12 @@
ENTER;
SAVETMPS;
PUSHMARK(sp);
- XPUSHs(sv_2mortal(newSVpv(key,0)));
- XPUSHs(sv_2mortal(newSVpv(val,0)));
+ XPUSHs(sv_2mortal(newSVpv(key, 0)));
+ XPUSHs(sv_2mortal(newSVpv(val, 0)));
PUTBACK;
rv = call_sv(tdata->cv, 0);
SPAGAIN;
rv = (1 == rv) ? POPi : 1;
@@ -44,12 +51,11 @@
/* rv of 0 aborts the traversal */
return rv;
}
-static MP_INLINE
-void mpxs_apr_table_do(pTHX_ I32 items, SV **MARK, SV **SP)
+static MP_INLINE void mpxs_apr_table_do(pTHX_ I32 items, SV **MARK, SV **SP)
{
apr_table_t *table;
SV *sub;
mpxs_table_do_cb_data_t tdata;
@@ -82,6 +88,40 @@
apr_table_do(mpxs_apr_table_do_cb, (void *)&tdata, table, NULL);
/* Free tdata.filter or wait for the pool to go away? */
return;
+};
+
+static MP_INLINE int apr_table_EXISTS(apr_table_t *t, const char *key)
+{
+ return (NULL == apr_table_get(t, key)) ? 0 : 1;
+}
+
+static MP_INLINE const char *apr_table_FIRSTKEY(SV *tsv)
+{
+ dTHX;
+ apr_table_t *t = mpxs_typemap_input_APR__Table(aTHX_ tsv, NULL);
+
+ if (apr_is_empty_table(t))
+ return NULL;
+
+ /* Note: SvCUR is used as the iterator state counter, why not ;-? */
+ return ((apr_table_entry_t *) t->a.elts)[SvCUR(SvRV(tsv))++].key;
+}
+
+static MP_INLINE const char *apr_table_NEXTKEY(SV *tsv, SV *p_key)
+{
+ dTHX;
+ apr_table_t *t = mpxs_typemap_input_APR__Table(aTHX_ tsv, NULL);
+
+ if (apr_is_empty_table(t))
+ return NULL;
+
+ if (SvCUR(SvRV(tsv)) < t->a.nelts) {
+ /* Note: SvCUR is used as the iterator state counter, why not ;-? */
+ return ((apr_table_entry_t *) t->a.elts)[((SvCUR(SvRV(tsv)))++)].key;
+ }
+ else {
+ return NULL;
+ }
}
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 -U5 -b -B -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/23 14:00:24
@@ -189,10 +189,17 @@
-apr_table_mergen
apr_table_set
-apr_table_setn
apr_table_unset
-apr_table_vdo
+ apr_table_FETCH
+ apr_table_STORE
+ apr_table_DELETE
+ apr_table_CLEAR
+ apr_table_FIRSTKEY
+ apr_table_NEXTKEY
+ apr_table_EXISTS
!MODULE=APR::File
-apr_file_open
-apr_file_close
-apr_file_namedpipe_create
PGP signature
