stas 2004/07/14 23:23:21
Modified: src/modules/perl modperl_common_util.c modperl_common_util.h
t/lib/TestAPRlib table.pm
xs/APR/Table APR__Table.h
xs/maps apr_functions.map
xs/tables/current/ModPerl FunctionTable.pm
. Changes
Log:
fix an old outstanding bug in the APR::Table's TIE interface with
each()/values() over tables with multi-values keys. Now the produced
order is correct and consistent with keys(). Though, values() works
correctly only with perl 5.8.x and higher.
Submitted by: Joe Schaefer
Revision Changes Path
1.3 +64 -6 modperl-2.0/src/modules/perl/modperl_common_util.c
Index: modperl_common_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_common_util.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -u -r1.2 -r1.3
--- modperl_common_util.c 22 Jun 2004 22:34:10 -0000 1.2
+++ modperl_common_util.c 15 Jul 2004 06:23:20 -0000 1.3
@@ -22,6 +22,41 @@
#include "modperl_common_util.h"
+
+/* Prefetch magic requires perl 5.8 */
+#if ((PERL_REVISION == 5) && (PERL_VERSION >= 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.
+ */
+
+MP_INLINE 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 /* End of prefetch magic */
+
MP_INLINE SV *modperl_hash_tie(pTHX_
const char *classname,
SV *tsv, void *p)
@@ -30,15 +65,25 @@
SV *rsv = sv_newmortal();
sv_setref_pv(rsv, classname, p);
+
+ /* Prefetch magic requires perl 5.8 */
+#if ((PERL_REVISION == 5) && (PERL_VERSION >= 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 +92,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 +103,7 @@
}
}
else {
- return (void *)SvObjIV(tsv);
+ return tsv;
}
}
else {
@@ -67,7 +112,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() */
1.3 +4 -0 modperl-2.0/src/modules/perl/modperl_common_util.h
Index: modperl_common_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_common_util.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -u -r1.2 -r1.3
--- modperl_common_util.h 22 Jun 2004 22:34:10 -0000 1.2
+++ modperl_common_util.h 15 Jul 2004 06:23:20 -0000 1.3
@@ -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);
1.5 +39 -2 modperl-2.0/t/lib/TestAPRlib/table.pm
Index: table.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/lib/TestAPRlib/table.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -u -r1.4 -r1.5
--- table.pm 15 Jul 2004 05:42:04 -0000 1.4
+++ table.pm 15 Jul 2004 06:23:21 -0000 1.5
@@ -11,13 +11,19 @@
use APR::Table ();
use APR::Pool ();
-use APR::Const -compile => ':table';
+use APR::Const -compile => ':table';
use constant TABLE_SIZE => 20;
our $filter_count;
sub num_of_tests {
- return 38;
+ my $tests = 50;
+
+ # tied hash values() for a table w/ multiple values for the same
+ # key
+ $tests += 2 if $] >= 5.008;
+
+ return $tests;
}
sub test {
@@ -173,6 +179,37 @@
my_filter($key, $table->{$key});
}
ok $filter_count == TABLE_SIZE;
+ }
+
+
+ # each, values
+ {
+ my $table = APR::Table::make($pool, 2);
+
+ $table->add("first" => 1);
+ $table->add("second" => 2);
+ $table->add("first" => 3);
+
+ my $i = 0;
+ while (my($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";
+ }
+
+ # this doesn't work with Perl < 5.8
+ if ($] >= 5.008) {
+ ok t_cmp "1,2,3", join(",", values %$table),
+ "table values";
+ ok t_cmp "first,1,second,2,first,3", join(",", %$table),
+ "table entries";
+ }
}
# overlap and compress routines
1.12 +38 -12 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.11
retrieving revision 1.12
diff -u -u -r1.11 -r1.12
--- APR__Table.h 4 Mar 2004 06:01:10 -0000 1.11
+++ APR__Table.h 15 Jul 2004 06:23:21 -0000 1.12
@@ -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,26 +121,53 @@
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)
{
dXSARGS;
@@ -153,11 +179,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 +193,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;
1.83 +3 -3 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.82
retrieving revision 1.83
diff -u -u -r1.82 -r1.83
--- apr_functions.map 9 Jun 2004 14:46:22 -0000 1.82
+++ apr_functions.map 15 Jul 2004 06:23:21 -0000 1.83
@@ -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
1.172 +27 -2 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.171
retrieving revision 1.172
diff -u -u -r1.171 -r1.172
--- FunctionTable.pm 12 Jul 2004 08:19:40 -0000 1.171
+++ FunctionTable.pm 15 Jul 2004 06:23:21 -0000 1.172
@@ -2,7 +2,7 @@
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by ModPerl::ParseSource/0.01
-# ! Mon Jul 12 00:41:18 2004
+# ! Wed Jul 14 22:25:32 2004
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -2619,6 +2619,27 @@
]
},
{
+ 'return_type' => 'SV *',
+ 'name' => 'modperl_hash_tied_object_rv',
+ 'attr' => [
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'classname'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'tsv'
+ }
+ ]
+ },
+ {
'return_type' => 'int',
'name' => 'modperl_header_parser_handler',
'args' => [
@@ -5598,7 +5619,7 @@
},
{
'return_type' => 'const char *',
- 'name' => 'mpxs_APR__Table_FIRSTKEY',
+ 'name' => 'mpxs_APR__Table_FETCH',
'attr' => [
'static',
'__inline__'
@@ -5611,6 +5632,10 @@
{
'type' => 'SV *',
'name' => 'tsv'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'key'
}
]
},
1.413 +5 -0 modperl-2.0/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.412
retrieving revision 1.413
diff -u -u -r1.412 -r1.413
--- Changes 15 Jul 2004 05:40:14 -0000 1.412
+++ Changes 15 Jul 2004 06:23:21 -0000 1.413
@@ -12,6 +12,11 @@
=item 1.99_15-dev
+fix an old outstanding bug in the APR::Table's TIE interface with
+each()/values() over tables with multi-values keys. Now the produced
+order is correct and consistent with keys(). Though, values() works
+correctly only with perl 5.8.x and higher. [Joe Schaefer]
+
require Perl 5.6.1, 5.6.0 isn't supported for a long time, but we
weren't aborting at the Makefile.PL stage [Stas]
