dougm 01/09/25 12:44:03
Modified: lib/ModPerl WrapXS.pm
src/modules/perl modperl_perl_includes.h modperl_util.c
modperl_util.h
t/response/TestAPR table.pm
todo api.txt
xs modperl_xs_util.h typemap
xs/APR/Table APR__Table.h
xs/maps apr_functions.map
xs/tables/current/ModPerl FunctionTable.pm
Log:
add APR::Table tied interface support
Submitted by: Philippe M . Chiasson <[EMAIL PROTECTED]>
Reviewed by: dougm
Revision Changes Path
1.22 +1 -0 modperl-2.0/lib/ModPerl/WrapXS.pm
Index: WrapXS.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/WrapXS.pm,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- WrapXS.pm 2001/09/13 02:37:37 1.21
+++ WrapXS.pm 2001/09/25 19:44:02 1.22
@@ -506,6 +506,7 @@
my %typemap = (
'Apache::RequestRec' => 'T_APACHEOBJ',
'apr_time_t' => 'T_APR_TIME',
+ 'APR::Table' => 'T_HASHOBJ',
);
sub write_typemap {
1.6 +4 -0 modperl-2.0/src/modules/perl/modperl_perl_includes.h
Index: modperl_perl_includes.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_perl_includes.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- modperl_perl_includes.h 2001/09/25 17:30:32 1.5
+++ modperl_perl_includes.h 2001/09/25 19:44:02 1.6
@@ -51,4 +51,8 @@
# define G_METHOD 64
#endif
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
#endif /* MODPERL_PERL_INCLUDES_H */
1.18 +47 -0 modperl-2.0/src/modules/perl/modperl_util.c
Index: modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- modperl_util.c 2001/08/08 16:20:32 1.17
+++ modperl_util.c 2001/09/25 19:44:02 1.18
@@ -339,3 +339,50 @@
return uri;
}
+MP_INLINE SV *modperl_hash_tie(pTHX_
+ const char *classname,
+ SV *tsv, void *p)
+{
+ SV *hv = (SV*)newHV();
+ SV *rsv = newSViv(0);
+
+ sv_setref_pv(rsv, classname, p);
+ sv_magic(hv, rsv, PERL_MAGIC_tied, Nullch, 0);
+
+ return SvREFCNT_inc(sv_bless(sv_2mortal(newRV_noinc(hv)),
+ gv_stashpv(classname, TRUE)));
+}
+
+MP_INLINE void *modperl_hash_tied_object(pTHX_
+ const char *classname,
+ SV *tsv)
+{
+ if (sv_derived_from(tsv, classname)) {
+ 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 *)MgObjIV(mg);
+ }
+ else {
+ Perl_warn(aTHX_ "Not a tied hash: (magic=%c)", mg);
+ }
+ }
+ else {
+ Perl_warn(aTHX_ "SV is not tied");
+ }
+ }
+ else {
+ return (void *)SvObjIV(tsv);
+ }
+ }
+ else {
+ Perl_croak(aTHX_
+ "argument is not a blessed reference "
+ "(expecting an %s derived object)", classname);
+ }
+
+ return NULL;
+}
1.17 +9 -0 modperl-2.0/src/modules/perl/modperl_util.h
Index: modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- modperl_util.h 2001/08/08 07:02:41 1.16
+++ modperl_util.h 2001/09/25 19:44:02 1.17
@@ -19,6 +19,7 @@
#endif
#define SvObjIV(o) SvIV((SV*)SvRV(o))
+#define MgObjIV(m) SvIV((SV*)SvRV(m->mg_obj))
MP_INLINE server_rec *modperl_sv2server_rec(pTHX_ SV *sv);
MP_INLINE request_rec *modperl_sv2request_rec(pTHX_ SV *sv);
@@ -49,5 +50,13 @@
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);
+
+/* tie %hash */
+MP_INLINE SV *modperl_hash_tie(pTHX_ const char *classname,
+ SV *tsv, void *p);
+
+/* tied %hash */
+MP_INLINE void *modperl_hash_tied_object(pTHX_ const char *classname,
+ SV *tsv);
#endif /* MODPERL_UTIL_H */
1.3 +29 -2 modperl-2.0/t/response/TestAPR/table.pm
Index: table.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPR/table.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- table.pm 2001/09/15 18:17:31 1.2
+++ table.pm 2001/09/25 19:44:03 1.3
@@ -14,9 +14,9 @@
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'));
@@ -59,6 +59,33 @@
$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;
}
1.5 +0 -4 modperl-2.0/todo/api.txt
Index: api.txt
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/api.txt,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- api.txt 2001/09/15 18:17:31 1.4
+++ api.txt 2001/09/25 19:44:03 1.5
@@ -5,10 +5,6 @@
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)
1.9 +4 -0 modperl-2.0/xs/modperl_xs_util.h
Index: modperl_xs_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/modperl_xs_util.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- modperl_xs_util.h 2001/05/05 02:16:00 1.8
+++ modperl_xs_util.h 2001/09/25 19:44:03 1.9
@@ -5,6 +5,10 @@
#undef mp_xs_sv2_r /* defined in modperl_xs_sv_convert.h */
#define mp_xs_sv2_r(sv) modperl_sv2request_rec(aTHX_ sv)
+#undef mp_xs_sv2_APR__Table
+#define mp_xs_sv2_APR__Table(sv) \
+ (apr_table_t *)modperl_hash_tied_object(aTHX_ "APR::Table", sv)
+
#define mpxs_Apache__RequestRec_pool(r) r->pool
#define mpxs_Apache__Connection_pool(c) c->pool
#define mpxs_Apache__URI_pool(u) ((modperl_uri_t *)u)->pool
1.5 +6 -0 modperl-2.0/xs/typemap
Index: typemap
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/typemap,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- typemap 2001/05/04 21:21:49 1.4
+++ typemap 2001/09/25 19:44:03 1.5
@@ -8,6 +8,9 @@
T_APACHEOBJ
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+T_HASHOBJ
+ $arg = modperl_hash_tie(aTHX_ \"${ntype}\", $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_HASHOBJ
+ $var = modperl_hash_tied_object(aTHX_ \"${ntype}\", $arg)
T_APACHEREF
$var = modperl_xs_sv2request_rec(aTHX_ $arg, \"$ntype\", cv)
1.4 +41 -0 modperl-2.0/xs/APR/Table/APR__Table.h
Index: APR__Table.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/APR/Table/APR__Table.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- APR__Table.h 2001/09/19 23:08:07 1.3
+++ APR__Table.h 2001/09/25 19:44:03 1.4
@@ -1,3 +1,8 @@
+#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;
@@ -84,4 +89,40 @@
/* 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;
+}
+
+/* Note: SvCUR is used as the iterator state counter, why not ;-? */
+#define mpxs_apr_table_iterix(sv) \
+SvCUR(SvRV(sv))
+
+#define mpxs_apr_table_nextkey(t, sv) \
+ ((apr_table_entry_t *) \
+ apr_table_elts(t)->elts)[mpxs_apr_table_iterix(sv)++].key
+
+static MP_INLINE const char *mpxs_APR__Table_NEXTKEY(SV *tsv, SV *key)
+{
+ dTHX;
+ apr_table_t *t = mp_xs_sv2_APR__Table(tsv);
+
+ if (apr_is_empty_table(t)) {
+ return NULL;
+ }
+
+ if (mpxs_apr_table_iterix(tsv) < apr_table_elts(t)->nelts) {
+ return mpxs_apr_table_nextkey(t, tsv);
+ }
+
+ return NULL;
+}
+
+static MP_INLINE const char *mpxs_APR__Table_FIRSTKEY(SV *tsv)
+{
+ mpxs_apr_table_iterix(tsv) = 0; /* reset iterator index */
+
+ return mpxs_APR__Table_NEXTKEY(tsv, Nullsv);
}
1.22 +7 -0 modperl-2.0/xs/maps/apr_functions.map
Index: apr_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/apr_functions.map,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- apr_functions.map 2001/09/17 01:06:08 1.21
+++ apr_functions.map 2001/09/25 19:44:03 1.22
@@ -191,6 +191,13 @@
-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
1.28 +79 -1 modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm
Index: FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- FunctionTable.pm 2001/09/25 18:02:39 1.27
+++ FunctionTable.pm 2001/09/25 19:44:03 1.28
@@ -2,7 +2,7 @@
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by ModPerl::ParseSource/0.01
-# ! Tue Sep 25 10:58:42 2001
+# ! Tue Sep 25 12:40:01 2001
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -1629,6 +1629,46 @@
]
},
{
+ 'return_type' => 'SV *',
+ 'name' => 'modperl_hash_tie',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'classname'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'tsv'
+ },
+ {
+ 'type' => 'void *',
+ 'name' => 'p'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'void *',
+ 'name' => 'modperl_hash_tied_object',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'classname'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'tsv'
+ }
+ ]
+ },
+ {
'return_type' => 'int',
'name' => 'modperl_header_parser_handler',
'args' => [
@@ -3340,6 +3380,44 @@
{
'type' => 'apr_bucket *',
'name' => 'bucket'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'int',
+ 'name' => 'mpxs_APR__Table_EXISTS',
+ 'args' => [
+ {
+ 'type' => 'apr_table_t *',
+ 'name' => 't'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'key'
+ }
+ ]
+ },
+ {
+ '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' => 'key'
}
]
},
