perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From j...@apache.org
Subject cvs commit: modperl-2.0/xs/APR/Pool APR__Pool.h
Date Mon, 04 Oct 2004 00:05:24 GMT
joes        2004/10/03 17:05:24

  Modified:    xs/APR/Pool APR__Pool.h
  Added:       t/apr    pool_lifetime.t
               t/response/TestAPR pool_lifetime.pm
  Log:
  Mark pools created by APR::Pool::new by adding sv_magic instead of
  apr_pool_userdata_set.  This allows such pools to be destroyed by
  apache before the SV object is DESTROYed by perl.
  
  http://marc.theaimsgroup.com/?l=apache-modperl-dev&w=2&r=1&s=ap_save_brigage&q=t
  Reviewed by: gozer, stas
  
  Revision  Changes    Path
  1.1                  modperl-2.0/t/apr/pool_lifetime.t
  
  Index: pool_lifetime.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestUtil;
  use Apache::TestRequest;
  use File::Spec::Functions qw(catfile);
  
  plan tests => 2;
  
  my $module   = 'TestAPR::pool_lifetime';
  my $location = '/' . Apache::TestRequest::module2path($module);
  
  t_debug "getting the same interp ID for $location";
  my $same_interp = Apache::TestRequest::same_interp_tie($location);
  
  my $skip = $same_interp ? 0 : 1;
  
  for (1..2) {
      my $expected = "Pong";
      my $received = get_body($same_interp, \&GET, $location);
      $skip++ unless defined $received;
      skip_not_same_interp(
          $skip,
          $expected,
          $received,
          "Pong"
      );
  }
  
  # if we fail to find the same interpreter, return undef (this is not
  # an error)
  sub get_body {
      my $res = eval {
          Apache::TestRequest::same_interp_do(@_);
      };
      return undef if $@ =~ /unable to find interp/;
      return $res->content if $res;
      die $@ if $@;
  }
  
  # make the tests resistant to a failure of finding the same perl
  # interpreter, which happens randomly and not an error.
  # the first argument is used to decide whether to skip the sub-test,
  # the rest of the arguments are passed to 'ok t_cmp';
  sub skip_not_same_interp {
      my $skip_cond = shift;
      if ($skip_cond) {
          skip "Skip couldn't find the same interpreter", 0;
      }
      else {
          my($package, $filename, $line) = caller;
          # trick ok() into reporting the caller filename/line when a
          # sub-test fails in sok()
          return eval <<EOE;
  #line $line $filename
      ok &t_cmp;
  EOE
      }
  }
  
  
  
  1.1                  modperl-2.0/t/response/TestAPR/pool_lifetime.pm
  
  Index: pool_lifetime.pm
  ===================================================================
  package TestAPR::pool_lifetime;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestUtil;
  use Apache::TestTrace;
  
  use Apache::RequestRec ();
  use APR::Pool ();
  
  use Apache::Const -compile => 'OK';
  
  my $pool;
  sub handler {
      my $r = shift;
      
      $r->print("Pong");
      $pool = $r->pool;
      
      Apache::OK;   
  }
  
  1;
  __END__
  
  PerlFixupHandler Apache::TestHandler::same_interp_fixup
  
  
  
  1.18      +103 -119  modperl-2.0/xs/APR/Pool/APR__Pool.h
  
  Index: APR__Pool.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/xs/APR/Pool/APR__Pool.h,v
  retrieving revision 1.17
  retrieving revision 1.18
  diff -u -r1.17 -r1.18
  --- APR__Pool.h	14 Jul 2004 23:15:01 -0000	1.17
  +++ APR__Pool.h	4 Oct 2004 00:05:24 -0000	1.18
  @@ -17,6 +17,10 @@
   
   typedef struct {
       SV *sv;
  +#ifdef USE_ITHREADS
  +    PerlInterpreter *perl;
  +    modperl_interp_t *interp;
  +#endif
   } mpxs_pool_account_t;
   
   /* XXX: this implementation has a problem with perl ithreads. if a
  @@ -33,6 +37,73 @@
    *   that?) may be we can skip those?
    */
   
  +#ifndef MP_SOURCE_SCAN
  +#include "apr_optional.h"
  +static
  +APR_OPTIONAL_FN_TYPE(modperl_interp_unselect) *modperl_opt_interp_unselect;
  +#endif
  +
  +#define MP_APR_POOL_SV_HAS_OWNERSHIP(sv) (mg_find(sv, PERL_MAGIC_ext) != NULL)
  +
  +#ifdef USE_ITHREADS
  +
  +#define MP_APR_POOL_SV_DROPS_OWNERSHIP(acct) STMT_START {               \
  +    dTHXa(acct->perl);                                                  \
  +    mg_free(acct->sv);                                                  \
  +    SvIVX(acct->sv) = 0;                                                \
  +    if (modperl_opt_interp_unselect && acct->interp) {                  \
  +        /* this will decrement the interp refcnt until                  \
  +         * there are no more references, in which case                  \
  +         * the interpreter will be putback into the mip                 \
  +         */                                                             \
  +        (void)modperl_opt_interp_unselect(acct->interp);                \
  +    }                                                                   \
  +} STMT_END
  +
  +#define MP_APR_POOL_SV_TAKES_OWNERSHIP(acct_sv, pool) STMT_START {      \
  +    mpxs_pool_account_t *acct = apr_palloc(pool, sizeof *acct);         \
  +    acct->sv = acct_sv;                                                 \
  +    acct->perl = aTHX;                                                  \
  +    SvIVX(acct_sv) = PTR2IV(pool);                                      \
  +                                                                        \
  +    sv_magic(acct_sv, Nullsv, PERL_MAGIC_ext,                           \
  +             MP_APR_POOL_NEW, sizeof(MP_APR_POOL_NEW));                 \
  +                                                                        \
  +    apr_pool_cleanup_register(pool, (void *)acct,                       \
  +                              mpxs_apr_pool_cleanup,                    \
  +                              apr_pool_cleanup_null);                   \
  +                                                                        \
  +    /* make sure interpreter is not putback into the mip                \
  +     * until this cleanup has run.                                      \
  +     */                                                                 \
  +    if ((acct->interp = MP_THX_INTERP_GET(aTHX))) {                     \
  +        acct->interp->refcnt++;                                         \
  +    }                                                                   \
  +} STMT_END
  +
  +#else /* !USE_ITHREADS */
  +
  +#define MP_APR_POOL_SV_DROPS_OWNERSHIP(acct) STMT_START {               \
  +    mg_free(acct->sv);                                                  \
  +    SvIVX(acct->sv) = 0;                                                \
  +} STMT_END
  +
  +#define MP_APR_POOL_SV_TAKES_OWNERSHIP(acct_sv, pool) STMT_START {      \
  +    mpxs_pool_account_t *acct = apr_palloc(pool, sizeof *acct);         \
  +    acct->sv = acct_sv;                                                 \
  +    SvIVX(acct_sv) = PTR2IV(pool);                                      \
  +                                                                        \
  +    sv_magic(acct_sv, Nullsv, PERL_MAGIC_ext,                           \
  +              MP_APR_POOL_NEW, sizeof(MP_APR_POOL_NEW));                \
  +                                                                        \
  +    apr_pool_cleanup_register(pool, (void *)acct,                       \
  +                              mpxs_apr_pool_cleanup,                    \
  +                              apr_pool_cleanup_null);                   \
  +} STMT_END
  +
  +#endif /* USE_ITHREADS */
  +
  +
   /* XXX: should we make it a new global tracing category
    * MOD_PERL_TRACE=p for tracing pool management? */
   #define MP_POOL_TRACE_DO 0
  @@ -50,26 +121,8 @@
   static MP_INLINE apr_status_t
   mpxs_apr_pool_cleanup(void *cleanup_data)
   {
  -    mpxs_pool_account_t *data;
  -    apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW,
  -                          (apr_pool_t *)cleanup_data);
  -    if (!(data && data->sv)) {
  -        /* if there is no data, there is nothing to unset */
  -        MP_POOL_TRACE(MP_FUNC, "this pool seems to be destroyed already");
  -    }
  -    else {
  -        MP_POOL_TRACE(MP_FUNC,
  -                      "pool 0x%lx contains a valid sv 0x%lx, invalidating it",
  -                      (unsigned long)data->sv, (unsigned long)cleanup_data);
  -
  -        /* invalidate all Perl objects referencing this sv */
  -        SvIVX(data->sv) = 0;
  -
  -        /* invalidate the reference stored in the pool */
  -        data->sv = NULL;
  -        /* data->sv will go away by itself when all objects will go away */
  -    }
  -
  +    mpxs_pool_account_t *acct = cleanup_data;
  +    MP_APR_POOL_SV_DROPS_OWNERSHIP(acct);
       return APR_SUCCESS;
   }
   
  @@ -100,25 +153,6 @@
                      (unsigned long)child_pool, (unsigned long)parent_pool);
       }
   
  -    /* Each newly created pool must be destroyed only once. Calling
  -     * apr_pool_destroy will destroy the pool and its children pools,
  -     * however a perl object for a sub-pool will still keep a pointer
  -     * to the pool which was already destroyed. When this object is
  -     * DESTROYed, apr_pool_destroy will be called again. In the best
  -     * case it'll try to destroy a non-existing pool, but in the worst
  -     * case it'll destroy a different valid pool which has been given
  -     * the same memory allocation wrecking havoc. Therefore we must
  -     * ensure that when sub-pools are destroyed via the parent pool,
  -     * their cleanup callbacks will destroy the guts of their perl
  -     * objects, so when those perl objects, pointing to memory
  -     * previously allocated by destroyed sub-pools or re-used already
  -     * by new pools, will get their time to DESTROY, they won't make a
  -     * mess, trying to destroy an already destroyed pool or even worse
  -     * a pool allocate in the place of the old one.
  -     */
  -    apr_pool_cleanup_register(child_pool, (void *)child_pool,
  -                              mpxs_apr_pool_cleanup,
  -                              apr_pool_cleanup_null);
   #if APR_POOL_DEBUG
       /* child <-> parent <-> ... <-> top ancestry traversal */
       {
  @@ -139,17 +173,30 @@
   #endif
   
       {
  -        mpxs_pool_account_t *data =
  -            (mpxs_pool_account_t *)apr_pcalloc(child_pool, sizeof(*data));
  -
           SV *rv = sv_setref_pv(NEWSV(0, 0), "APR::Pool", (void*)child_pool);
  +        SV *sv = SvRV(rv);
   
  -        data->sv = SvRV(rv);
  +        /* Each newly created pool must be destroyed only once. Calling
  +         * apr_pool_destroy will destroy the pool and its children pools,
  +         * however a perl object for a sub-pool will still keep a pointer
  +         * to the pool which was already destroyed. When this object is
  +         * DESTROYed, apr_pool_destroy will be called again. In the best
  +         * case it'll try to destroy a non-existing pool, but in the worst
  +         * case it'll destroy a different valid pool which has been given
  +         * the same memory allocation wrecking havoc. Therefore we must
  +         * ensure that when sub-pools are destroyed via the parent pool,
  +         * their cleanup callbacks will destroy the guts of their perl
  +         * objects, so when those perl objects, pointing to memory
  +         * previously allocated by destroyed sub-pools or re-used already
  +         * by new pools, will get their time to DESTROY, they won't make a
  +         * mess, trying to destroy an already destroyed pool or even worse
  +         * a pool allocate in the place of the old one.
  +         */
   
  -        MP_POOL_TRACE(MP_FUNC, "sub-pool p: 0x%lx, sv: 0x%lx, rv: 0x%lx",
  -                      (unsigned long)child_pool, data->sv, rv);
  +        MP_APR_POOL_SV_TAKES_OWNERSHIP(sv, child_pool);
   
  -        apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, child_pool);
  +        MP_POOL_TRACE(MP_FUNC, "sub-pool p: 0x%lx, sv: 0x%lx, rv: 0x%lx",
  +                      (unsigned long)child_pool, sv, rv);
   
           return rv;
       }
  @@ -158,10 +205,9 @@
   static MP_INLINE void mpxs_APR__Pool_clear(pTHX_ SV *obj)
   {
       apr_pool_t *p = mp_xs_sv2_APR__Pool(obj);
  -    mpxs_pool_account_t *data;
  +    SV *sv = SvRV(obj);
   
  -    apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
  -    if (!(data && data->sv)) {
  +    if (!MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) {
           MP_POOL_TRACE(MP_FUNC, "parent pool (0x%lx) is a core pool",
                         (unsigned long)p);
           apr_pool_clear(p);
  @@ -171,20 +217,15 @@
       MP_POOL_TRACE(MP_FUNC,
                     "parent pool (0x%lx) is a custom pool, sv 0x%lx",
                     (unsigned long)p,
  -                  (unsigned long)data->sv);
  +                  (unsigned long)sv);
   
       apr_pool_clear(p);
   
  -    /* apr_pool_clear removes all the user data, so we need to restore
  +    /* apr_pool_clear runs & removes the cleanup, so we need to restore
        * it. Since clear triggers mpxs_apr_pool_cleanup call, our
        * object's guts get nuked too, so we need to restore them too */
   
  -    /* this is sv_setref_pv, but for an existing object */
  -    sv_setiv(newSVrv(obj, "APR::Pool"), PTR2IV((void*)p));
  -    data->sv = SvRV(obj);
  -
  -    /* reinstall the user data */
  -    apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
  +    MP_APR_POOL_SV_TAKES_OWNERSHIP(sv, p);
   }
   
   
  @@ -203,11 +244,6 @@
    * @param data   internal storage
    */
   
  -#ifndef MP_SOURCE_SCAN
  -#include "apr_optional.h"
  -static
  -APR_OPTIONAL_FN_TYPE(modperl_interp_unselect) *modperl_opt_interp_unselect;
  -#endif
   
   static apr_status_t mpxs_cleanup_run(void *data)
   {
  @@ -294,35 +330,12 @@
       apr_pool_t *parent_pool = apr_pool_parent_get(child_pool);
   
       if (parent_pool) {
  -        /* ideally this should be done by mp_xs_APR__Pool_2obj. Though
  -         * since most of the time we don't use custom pools, we don't
  -         * want the overhead of reading and writing pool's userdata in
  -         * the general case. therefore we do it here and in
  -         * mpxs_apr_pool_create. Though if there are any other
  -         * functions, that return perl objects whose guts include a
  -         * reference to a custom pool, they must do the ref-counting
  -         * as well.
  -         */
  -        mpxs_pool_account_t *data;
  -        apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, parent_pool);
  -        if (data && data->sv) {
  -            MP_POOL_TRACE(MP_FUNC,
  -                          "parent pool (0x%lx) is a custom pool, sv 0x%lx",
  -                          (unsigned long)parent_pool,
  -                          (unsigned long)data->sv);
  -
  -            return newRV_inc(data->sv);
  -        }
  -        else {
  -            MP_POOL_TRACE(MP_FUNC, "parent pool (0x%lx) is a core pool",
  -                          (unsigned long)parent_pool);
  -            return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
  -        }
  +        return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
       }
       else {
           MP_POOL_TRACE(MP_FUNC, "pool (0x%lx) has no parents",
                         (unsigned long)child_pool);
  -                      return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
  +        return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
       }
   }
   
  @@ -332,40 +345,11 @@
    */
   static MP_INLINE void mpxs_apr_pool_DESTROY(pTHX_ SV *obj)
   {
  -    apr_pool_t *p;
       SV *sv = SvRV(obj);
   
  -    /* MP_POOL_TRACE(MP_FUNC, "DESTROY 0x%lx-0x%lx",       */
  -    /*              (unsigned long)obj,(unsigned long)sv); */
  -    /* do_sv_dump(0, Perl_debug_log, obj, 0, 4, FALSE, 0); */
  -
  -    p = mpxs_sv_object_deref(obj, apr_pool_t);
  -    if (!p) {
  -        /* non-custom pool */
  -        MP_POOL_TRACE(MP_FUNC, "skip apr_pool_destroy: not a custom pool");
  -        return;
  -    }
  -
  -    if (sv && SvOK(sv)) {
  -        mpxs_pool_account_t *data;
  -
  -        apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
  -        if (!(data && data->sv)) {
  -            MP_POOL_TRACE(MP_FUNC, "skip apr_pool_destroy: no sv found");
  -            return;
  -        }
  -
  -        if (SvREFCNT(sv) == 1) {
  -            MP_POOL_TRACE(MP_FUNC, "call apr_pool_destroy: last reference");
  -            apr_pool_destroy(p);
  -        }
  -        else {
  -            /* when the pool object dies, sv's ref count decrements
  -             * itself automatically */
  -            MP_POOL_TRACE(MP_FUNC,
  -                          "skip apr_pool_destroy: refcount > 1 (%d)",
  -                          SvREFCNT(sv));
  -        }
  +    if (MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) {
  +        apr_pool_t *p = mpxs_sv_object_deref(obj, apr_pool_t);
  +        apr_pool_destroy(p);
       }
   }
   
  
  
  

Mime
View raw message