perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From do...@apache.org
Subject cvs commit: modperl-2.0/xs/tables/current/ModPerl FunctionTable.pm
Date Tue, 25 Sep 2001 19:44:03 GMT
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 <gozer@cpan.org>
  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'
         }
       ]
     },
  
  
  

Mime
View raw message