? Perhaps
? config.nice
Index: docs/api/APR/Table.pod
===================================================================
RCS file: /home/cvspublic/modperl-docs/src/docs/2.0/api/APR/Table.pod,v
retrieving revision 1.9
diff -u -r1.9 Table.pod
--- docs/api/APR/Table.pod 22 May 2004 02:03:26 -0000 1.9
+++ docs/api/APR/Table.pod 15 Jul 2004 00:06:54 -0000
@@ -848,9 +848,18 @@
remark: C<APR::Table> can hold more than one key-value pair sharing
the same key, so when using a table through the tied interface, the
first entry found with the right key will be used, completely
-disregarding possible other entries with the same key. The only
-exception to this is if you iterate over the list with C<each()>, then
-you can access all key-value pairs that share the same key.
+disregarding possible other entries with the same key. So although
+C<keys ()> will return the list of table keys in the order they
+were added, in previous releases C<values ()> would always list
+the first value of the corresponding multivalued key. Now values()
+will correctly lists the corresponding value; however the adopted
+fix requires perl 5.8.0 or better. Folks needing to portably iterate
+over the key-value pairs may use C<each()> (which fully supports
+multivalued keys now), or C<APR::Table::do>.
+
+
+
+
=head2 C<EXISTS>
@@ -955,7 +964,25 @@
=back
+When iterating through the table's entries
+with C<each()>, FETCH will return the current value
+of a multivalued key. For example
+
+ $table->add("a" => 1);
+ $table->add("b" => 2);
+ $table->add("c" => 3);
+
+ ($k, $v) = each %$table; # (a, 1)
+ print $table->{a}; # prints 1
+
+ ($k, $v) = each %$table; # (b, 2)
+ print $table->{a}; # prints 1
+
+ ($k, $v) = each %$table; # (a, 3)
+ print $table->{a}; # prints 3 !!!
+ ($k, $v) = each %$table; # (undef, undef)
+ print $table->{a}; # prints 1
=head1 See Also
Index: src/modules/perl/modperl_common_util.c
===================================================================
RCS file: /home/cvspublic/modperl-2.0/src/modules/perl/modperl_common_util.c,v
retrieving revision 1.2
diff -u -r1.2 modperl_common_util.c
--- src/modules/perl/modperl_common_util.c 22 Jun 2004 22:34:10 -0000 1.2
+++ src/modules/perl/modperl_common_util.c 15 Jul 2004 00:06:54 -0000
@@ -22,6 +22,40 @@
#include "modperl_common_util.h"
+
+#if (PERL_VERSION >= 8) /* Prefetch magic requires perl 5.8 */
+
+/* A custom MGVTBL with mg_copy slot filled in allows
+ * us to FETCH a table entry immediately during iteration.
+ * For multivalued keys this is essential in order to get
+ * the value corresponding to the current key, otherwise
+ * values() will always report the first value repeatedly.
+ * With this MGVTBL the keys() list always matches up with
+ * the values() list, even in the multivalued case.
+ * We only prefetch the value during iteration, because the
+ * prefetch adds overhead (an unnecessary FETCH call) to EXISTS
+ * and STORE operations. This way they are only "penalized"
+ * when the perl program is iterating via each(), which seems
+ * to be a reasonable tradeoff.
+ */
+
+static int modperl_table_magic_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
+ const char *name, int namelen)
+{
+ /* prefetch the value whenever we're iterating over the keys */
+ MAGIC *tie_magic = mg_find(nsv, PERL_MAGIC_tiedelem);
+ SV *obj = SvRV(tie_magic->mg_obj);
+ if (SvCUR(obj))
+ SvGETMAGIC(nsv);
+ return 0;
+}
+
+
+static const MGVTBL modperl_table_magic_prefetch = {0, 0, 0, 0, 0,
+ modperl_table_magic_copy};
+
+#endif /* Prefetch magic */
+
MP_INLINE SV *modperl_hash_tie(pTHX_
const char *classname,
SV *tsv, void *p)
@@ -30,15 +64,22 @@
SV *rsv = sv_newmortal();
sv_setref_pv(rsv, classname, p);
+
+#if (PERL_VERSION >= 8) /* Prefetch magic requires perl 5.8 */
+ sv_magic(hv, NULL, PERL_MAGIC_ext, Nullch, -1);
+ SvMAGIC(hv)->mg_virtual = (MGVTBL *)&modperl_table_magic_prefetch;
+ SvMAGIC(hv)->mg_flags |= MGf_COPY;
+#endif /* End of prefetch magic */
+
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)
+MP_INLINE SV *modperl_hash_tied_object_rv(pTHX_
+ const char *classname,
+ SV *tsv)
{
if (sv_derived_from(tsv, classname)) {
if (SVt_PVHV == SvTYPE(SvRV(tsv))) {
@@ -47,7 +88,7 @@
if (SvMAGICAL(hv)) {
if ((mg = mg_find(hv, PERL_MAGIC_tied))) {
- return (void *)MgObjIV(mg);
+ return mg->mg_obj;
}
else {
Perl_warn(aTHX_ "Not a tied hash: (magic=%c)", mg);
@@ -58,7 +99,7 @@
}
}
else {
- return (void *)SvObjIV(tsv);
+ return tsv;
}
}
else {
@@ -67,7 +108,20 @@
"(expecting an %s derived object)", classname);
}
- return NULL;
+ return &PL_sv_undef;
+}
+
+MP_INLINE void *modperl_hash_tied_object(pTHX_
+ const char *classname,
+ SV *tsv)
+{
+ SV *rv = modperl_hash_tied_object_rv(aTHX_ classname, tsv);
+ if (SvROK(rv)) {
+ return (void *)SvIVX(SvRV(rv));
+ }
+ else {
+ return NULL;
+ }
}
/* same as Symbol::gensym() */
Index: src/modules/perl/modperl_common_util.h
===================================================================
RCS file: /home/cvspublic/modperl-2.0/src/modules/perl/modperl_common_util.h,v
retrieving revision 1.2
diff -u -r1.2 modperl_common_util.h
--- src/modules/perl/modperl_common_util.h 22 Jun 2004 22:34:10 -0000 1.2
+++ src/modules/perl/modperl_common_util.h 15 Jul 2004 00:06:55 -0000
@@ -75,6 +75,10 @@
SV *tsv, void *p);
/* tied %hash */
+MP_INLINE SV *modperl_hash_tied_object_rv(pTHX_
+ const char *classname,
+ SV *tsv);
+/* tied %hash */
MP_INLINE void *modperl_hash_tied_object(pTHX_ const char *classname,
SV *tsv);
Index: t/apr-ext/table.t
===================================================================
RCS file: /home/cvspublic/modperl-2.0/t/apr-ext/table.t,v
retrieving revision 1.1
diff -u -r1.1 table.t
--- t/apr-ext/table.t 16 Jun 2004 03:55:48 -0000 1.1
+++ t/apr-ext/table.t 15 Jul 2004 00:06:55 -0000
@@ -1,15 +1,37 @@
+use warnings FATAL => 'all';
+use strict;
+
use Apache::Test;
+use Apache::TestUtil;
use blib;
use Apache2;
-plan tests => 1;
+plan tests => 15;
+
+use APR;
+use APR::Table;
+use APR::Pool;
-require APR;
-require APR::Table;
-require APR::Pool;
my $p = APR::Pool->new;
my $table = APR::Table::make($p, 2);
ok ref $table eq 'APR::Table';
+
+$table->add("first" => 1);
+$table->add("second" => 2);
+$table->add("first" => 3);
+
+my $i = 0;
+while (($a,$b) = each %$table) {
+ my $key = ("first", "second")[$i % 2];
+ my $val = ++$i;
+ ok t_cmp $a, $key, "table each: key test";
+ ok t_cmp $b, $val, "table each: value test";
+ ok t_cmp $table->{$a}, $val, "table each: get test";
+ ok t_cmp tied(%$table)->FETCH($a), $val, "table each: tied get test";
+}
+
+ok t_cmp "1,2,3", join(",", values %$table), "table values";
+ok t_cmp "first,1,second,2,first,3", join(",", %$table), "table entries";
Index: xs/APR/Table/APR__Table.h
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/APR/Table/APR__Table.h,v
retrieving revision 1.11
diff -u -r1.11 APR__Table.h
--- xs/APR/Table/APR__Table.h 4 Mar 2004 06:01:10 -0000 1.11
+++ xs/APR/Table/APR__Table.h 15 Jul 2004 00:06:56 -0000
@@ -13,7 +13,6 @@
* limitations under the License.
*/
-#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
@@ -122,24 +121,45 @@
static MP_INLINE const char *mpxs_APR__Table_NEXTKEY(pTHX_ SV *tsv, SV *key)
{
- apr_table_t *t = mp_xs_sv2_APR__Table(tsv);
+ apr_table_t *t;
+ SV *rv = modperl_hash_tied_object_rv(aTHX_ "APR::Table", tsv);
+ if (!SvROK(rv)) {
+ Perl_croak(aTHX_ "Usage: $table->NEXTKEY($key): "
+ "first argument not an APR::Table object");
+ }
+ t = (apr_table_t *)SvIVX(SvRV(rv));
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);
+ if (key == NULL) {
+ mpxs_apr_table_iterix(rv) = 0; /* reset iterator index */
}
-
+ if (mpxs_apr_table_iterix(rv) < apr_table_elts(t)->nelts) {
+ return mpxs_apr_table_nextkey(t, rv);
+ }
+ mpxs_apr_table_iterix(rv) = 0;
return NULL;
}
-static MP_INLINE const char *mpxs_APR__Table_FIRSTKEY(pTHX_ SV *tsv)
-{
- mpxs_apr_table_iterix(tsv) = 0; /* reset iterator index */
+/* Try to shortcut apr_table_get by fetching the key using the current
+ * iterator (unless it's inactive or points at different key).
+ */
+
+static MP_INLINE const char *mpxs_APR__Table_FETCH(pTHX_ SV *tsv,
+ const char *key)
+{
+ SV* rv = modperl_hash_tied_object_rv(aTHX_ "APR::Table", tsv);
+ const int i = mpxs_apr_table_iterix(rv);
+ apr_table_t *t = (apr_table_t *)SvIVX(SvRV(rv));
+ const apr_array_header_t *arr = apr_table_elts(t);
+ apr_table_entry_t *elts = (apr_table_entry_t *)arr->elts;
- return mpxs_APR__Table_NEXTKEY(aTHX_ tsv, Nullsv);
+ if (i > 0 && i <= arr->nelts && !strcasecmp(key, elts[i-1].key)) {
+ return elts[i-1].val;
+ }
+ else
+ return apr_table_get(t, key);
}
static XS(MPXS_apr_table_get)
@@ -153,11 +173,11 @@
mpxs_PPCODE({
APR__Table t = modperl_hash_tied_object(aTHX_ "APR::Table", ST(0));
const char *key = (const char *)SvPV_nolen(ST(1));
-
+
if (!t) {
XSRETURN_UNDEF;
}
-
+
if (GIMME_V == G_SCALAR) {
const char *val = apr_table_get(t, key);
@@ -167,9 +187,9 @@
}
else {
const apr_array_header_t *arr = apr_table_elts(t);
- apr_table_entry_t *elts = (apr_table_entry_t *)arr->elts;
+ apr_table_entry_t *elts = (apr_table_entry_t *)arr->elts;
int i;
-
+
for (i = 0; i < arr->nelts; i++) {
if (!elts[i].key || strcasecmp(elts[i].key, key)) {
continue;
Index: xs/maps/apr_functions.map
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/maps/apr_functions.map,v
retrieving revision 1.82
diff -u -r1.82 apr_functions.map
--- xs/maps/apr_functions.map 9 Jun 2004 14:46:22 -0000 1.82
+++ xs/maps/apr_functions.map 15 Jul 2004 00:06:56 -0000
@@ -253,12 +253,12 @@
-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
+ const char *:DEFINE_FIRSTKEY | mpxs_APR__Table_NEXTKEY | SV *:tsv, SV *:key=Nullsv
+ mpxs_APR__Table_NEXTKEY | | SV *:tsv, SV *:key=&PL_sv_undef
+ mpxs_APR__Table_FETCH
mpxs_APR__Table_EXISTS
!MODULE=APR::File
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.171
diff -u -r1.171 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 12 Jul 2004 08:19:40 -0000 1.171
+++ xs/tables/current/ModPerl/FunctionTable.pm 15 Jul 2004 00:07:06 -0000
@@ -5598,7 +5598,7 @@
},
{
'return_type' => 'const char *',
- 'name' => 'mpxs_APR__Table_FIRSTKEY',
+ 'name' => 'mpxs_APR__Table_FETCH',
'attr' => [
'static',
'__inline__'
@@ -5611,6 +5611,10 @@
{
'type' => 'SV *',
'name' => 'tsv'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'key'
}
]
},
--
Joe Schaefer
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
