perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0 Changes
Date Thu, 15 Jul 2004 06:23:21 GMT
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]
   
  
  
  

Mime
View raw message