Now, this patch should be very close to what it will end up being.
Worth noting now, I generalized the tie'ing mechanism and ended up with:
SV *mpxs_typemap_output_tied()
void *mpxs_typemap_input_tied()
If something else needs a tied interface, output_tied will make a magical tied
SV with a void * of your choice and input_tied will give you that pointer back
from a magical SV. For more details, check out xs/typemap for T_APRTABLEOBJ
I think I got rid of all the issues I had about this one.
Having ALIAS: support in the generated XS sure would be nice though.
Compiles 100% cleanly and passes all tests, yai !
Gozer out.
/home/gozer/sources/mod_perl2/deps/perl/bin/perl build/make_diff
Index: lib/ModPerl/WrapXS.pm
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/lib/ModPerl/WrapXS.pm,v
retrieving revision 1.21
diff -u -U15 -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/24 15:59:37
@@ -494,30 +494,31 @@
$isa
use $loader ();
our \$VERSION = '0.01';
$loader\::load __PACKAGE__;
$code
1;
__END__
EOF
}
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;
my $map = $typemap->get;
my %seen;
my $fh = $self->open_class_file('ModPerl::WrapXS', 'typemap');
print $fh "$self->{noedit_warning_hash}\n";
while (my($type, $class) = each %$map) {
$class ||= $type;
next if $seen{$type}++ || $typemap->special($class);
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 -U15 -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/24 15:59:37
@@ -31,16 +31,20 @@
/* avoiding namespace collisions */
#ifdef list
# undef list
#endif
/* avoiding -Wall warning */
#undef dNOOP
#define dNOOP extern int __attribute__ ((unused)) Perl___notused
#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 -U15 -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/24 15:59:37
@@ -327,15 +327,65 @@
{
modperl_cleanup_data_t *cdata =
(modperl_cleanup_data_t *)apr_pcalloc(p, sizeof(*cdata));
cdata->pool = p;
cdata->data = data;
return cdata;
}
MP_INLINE modperl_uri_t *modperl_uri_new(apr_pool_t *p)
{
modperl_uri_t *uri = (modperl_uri_t *)apr_pcalloc(p, sizeof(*uri));
uri->pool = p;
return uri;
}
+MP_INLINE SV *mpxs_typemap_output_tied(pTHX_
+ const char *class,
+ SV *tsv,
+ void *p)
+{
+ SV *hv = (SV *)newHV();
+ SV *rsv = newSViv(0);
+
+ sv_setref_pv(rsv, class, p);
+ sv_magic(hv, rsv, PERL_MAGIC_tied, Nullch, 0);
+ return SvREFCNT_inc(sv_bless
+ (sv_2mortal(newRV_noinc(hv)),
+ gv_stashpv(class, TRUE)));
+}
+
+MP_INLINE void *mpxs_typemap_input_tied(pTHX_
+ const char *class,
+ SV *tsv,
+ void *p)
+{
+ if (sv_derived_from(tsv, class)) {
+ if (SVt_PVHV == SvTYPE(SvRV(tsv))) {
+ SV *hv = SvRV(tsv);
+ MAGIC *mg;
+
+ if (SvMAGICAL(hv)) {
+ if ((mg = mg_find(hv, PERL_MAGIC_tied))) {
+ return (void *)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 (void *)SvIV((SV *)SvRV(tsv));
+ }
+ }
+ else {
+ Perl_croak(aTHX_
+ "argument is not a blessed reference (expecting an %s derived
+object)",class);
+ }
+
+ 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 -U15 -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/24 15:59:37
@@ -38,16 +38,19 @@
int modperl_require_module(pTHX_ const char *pv, int logfailure);
int modperl_require_file(pTHX_ const char *pv, int logfailure);
char *modperl_server_desc(server_rec *s, apr_pool_t *p);
void modperl_xs_dl_handles_clear(pTHXo);
apr_array_header_t *modperl_xs_dl_handles_get(pTHX_ apr_pool_t *p);
void modperl_xs_dl_handles_close(apr_pool_t *p, apr_array_header_t *handles);
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_tied(pTHX_ const char *class, SV *tsv, void *p);
+MP_INLINE void *mpxs_typemap_input_tied(pTHX_ const char *class, SV *tsv, void *p);
+
#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 -U15 -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/24 16:43:16
@@ -2,33 +2,33 @@
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::Const -compile => 'OK';
use APR::Table ();
my $filter_count;
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;
ok $table->get('foo') eq 'bar';
ok $table->unset('foo') || 1;
ok not defined $table->get('foo');
for (1..$TABLE_SIZE) {
$table->set(chr($_+97), $_);
}
@@ -47,30 +47,57 @@
$table->do(sub {
my ($key,$value) = @_;
$filter_count++;
unless ($key eq chr($value+97)) {
die "arguments I recieved are bogus($key,$value)";
}
return 1;
});
ok $filter_count == $TABLE_SIZE;
$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) = @_;
$filter_count++;
unless ($key eq chr($value+97)) {
die "arguments I recieved are bogus($key,$value)";
}
return 1;
}
sub my_filter_stop {
my ($key,$value) = @_;
$filter_count++;
Index: todo/api.txt
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/todo/api.txt,v
retrieving revision 1.4
diff -u -U15 -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/24 15:59:37
@@ -1,26 +1,22 @@
important parts of the api that are missing
in no particular order
------------------------------------------
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}:
deprecated, but should be included in Apache::compat
$r->pnotes:
not yet implemented
$r->subprocess_env:
in void context should populate %ENV as 1.x does
$r->chdir_file:
not safe for threaded environments. should at least unshift @INC with
Index: xs/typemap
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/xs/typemap,v
retrieving revision 1.4
diff -u -U15 -b -B -I'$Id' -I'$Revision' -r1.4 typemap
--- xs/typemap 2001/05/04 21:21:49 1.4
+++ xs/typemap 2001/09/24 16:44:24
@@ -1,35 +1,41 @@
TYPEMAP
void * T_VPTR
char_len * T_CHAR_LEN
const char_len * T_CONST_CHAR_LEN
######################################################################
OUTPUT
T_APACHEOBJ
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+T_APRTABLEOBJ
+ $arg = mpxs_typemap_output_tied(aTHX_ \"${ntype}\", $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_tied(aTHX_ \"${ntype}\", $arg, $var)
T_APACHEREF
$var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
T_VPTR
$var = INT2PTR($type,SvIV(SvROK($arg) ? SvRV($arg) : $arg))
T_APR_TIME
$var = (apr_time_t)(SvNV($arg) * APR_USEC_PER_SEC)
T_CHAR_LEN
$var = (char *)SvPV($arg, ${var}_len)
T_CONST_CHAR_LEN
$var = (const char *)SvPV($arg, ${var}_len)
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 -U15 -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/24 16:46:07
@@ -1,15 +1,22 @@
+#define mp_xs_sv2_APR__Table(sv) mpxs_typemap_input_tied(aTHX_ "APR::Table", sv, NULL)
+
+#define mpxs_APR__Table_FETCH apr_table_get
+#define mpxs_APR__Table_STORE apr_table_set
+#define mpxs_APR__Table_DELETE apr_table_unset
+#define mpxs_APR__Table_CLEAR apr_table_clear
+
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 *);
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;
@@ -72,16 +79,50 @@
apr_hash_set(tdata.filter, filter_entry, len, "1");
MARK++;
}
}
/* XXX: would be nice to be able to call apr_table_vdo directly,
* but I don't think it's possible to create/populate something
* that smells like a va_list with our list of filters specs
*/
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 mpxs_APR__Table_EXISTS(apr_table_t *t, const char *key)
+{
+ return (NULL == apr_table_get(t, key)) ? 0 : 1;
+}
+
+static MP_INLINE const char *mpxs_APR__Table_FIRSTKEY(SV *tsv)
+{
+ dTHX;
+ apr_table_t *t = mp_xs_sv2_APR__Table(tsv);
+
+ 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 *mpxs_APR__Table_NEXTKEY(SV *tsv, SV *p_key)
+{
+ dTHX;
+ apr_table_t *t = mp_xs_sv2_APR__Table(tsv);
+
+ 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 -U15 -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/24 16:18:44
@@ -179,30 +179,37 @@
apr_table_clear
apr_table_copy | | t, p
apr_table_make
apr_table_overlap
apr_table_overlay | | base, overlay, p
apr_table_add
-apr_table_addn
apr_table_do | mpxs_ | ...
apr_table_get
apr_table_merge
-apr_table_mergen
apr_table_set
-apr_table_setn
apr_table_unset
-apr_table_vdo
+ const char *:DEFINE_FETCH | | apr_table_t *:t, const char *:key
+ void:DEFINE_STORE | | apr_table_t *:t, const char *:key, const char *:value
+ void:DEFINE_DELETE | | apr_table_t *:t, const char *:key
+ void:DEFINE_CLEAR | | apr_table_t *:t
+ mpxs_APR__Table_FIRSTKEY
+ mpxs_APR__Table_NEXTKEY
+ mpxs_APR__Table_EXISTS
!MODULE=APR::File
-apr_file_open
-apr_file_close
-apr_file_namedpipe_create
apr_file_pipe_create
-apr_file_dup
-apr_file_flush
-apr_file_eof
-apr_file_gets
-apr_file_printf
-apr_file_write_full
-apr_file_read_full
-apr_file_getc
-apr_file_ungetc
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/anoncvs/mod_perl-2-cvs/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.26
diff -u -U15 -b -B -I'$Id' -I'$Revision' -r1.26 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 2001/09/15 18:17:31 1.26
+++ xs/tables/current/ModPerl/FunctionTable.pm 2001/09/24 16:19:04
@@ -3998,30 +3998,68 @@
{
'type' => 'I32',
'name' => 'items'
},
{
'type' => 'SV **',
'name' => 'mark'
},
{
'type' => 'SV **',
'name' => 'sp'
}
]
},
{
+ 'return_type' => 'const char *',
+ 'name' => 'mpxs_APR__Table_FIRSTKEY',
+ 'args' => [
+ {
+ 'type' => 'SV *',
+ 'name' => 'tsv'
+ },
+ ]
+ },
+ {
+ 'return_type' => 'const char *',
+ 'name' => 'mpxs_APR__Table_NEXTKEY',
+ 'args' => [
+ {
+ 'type' => 'SV *',
+ 'name' => 'tsv'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'p_key'
+ },
+ ]
+ },
+ {
+ 'return_type' => 'int',
+ 'name' => 'mpxs_APR__Table_EXISTS',
+ 'args' => [
+ {
+ 'type' => 'apr_table_t *',
+ 'name' => 't'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'key'
+ },
+ ]
+ },
+ {
'return_type' => 'apr_uri_t *',
'name' => 'mpxs_apr_uri_parse',
'args' => [
{
'type' => 'PerlInterpreter *',
'name' => 'my_perl'
},
{
'type' => 'SV *',
'name' => 'classname'
},
{
'type' => 'SV *',
'name' => 'obj'
},
--
+----------------------------------------------------+
| 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}'
PGP signature
