perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From ran...@apache.org
Subject cvs commit: modperl-2.0/t/response/TestAPR pool.pm
Date Thu, 15 Jul 2004 15:33:37 GMT
randyk      2004/07/15 08:33:37

  Modified:    t/response/TestAPR pool.pm
  Added:       t/apr-ext pool.t
               t/lib/TestAPRlib pool.pm
  Log:
  Reviewed by:	stas
  put common pool tests under t/lib/TestAPRlib/, and call them
  from both t/apr/ and t/apr-ext/.
  
  Revision  Changes    Path
  1.1                  modperl-2.0/t/apr-ext/pool.t
  
  Index: pool.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  use Apache::Test;
  
  use TestAPRlib::pool;
  
  plan tests => TestAPRlib::pool::num_of_tests();
  
  TestAPRlib::pool::test();
  
  
  
  1.1                  modperl-2.0/t/lib/TestAPRlib/pool.pm
  
  Index: pool.pm
  ===================================================================
  package TestAPRlib::pool;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestUtil;
  use Apache::TestTrace;
  
  use APR::Pool ();
  use APR::Table ();
  use APR::Table ();
  
  sub num_of_tests {
      return 65;
  }
  
  sub test {
  
      my $pool = APR::Pool->new();
      my $table = APR::Table::make($pool, 2);
      ### custom pools ###
  
  
      # test: explicit pool object destroy destroys the custom pool
      {
          my $p = APR::Pool->new;
  
          $p->cleanup_register(\&set_cleanup, [$table, 'new destroy']);
  
          ok t_cmp(ancestry_count($p), 1,
                   "a new pool has one ancestor: the global pool");
  
          # explicity destroy the object
          $p->destroy;
  
          my @notes = $table->get('cleanup');
  
          ok t_cmp(scalar(@notes), 1, "should be 1 note");
  
          ok t_cmp($notes[0], 'new destroy');
  
          $table->clear;
      }
  
  
  
  
  
      # test: lexical scoping DESTROYs the custom pool
      {
          {
              my $p = APR::Pool->new;
  
              ok t_cmp(ancestry_count($p), 1,
                   "a new pool has one ancestor: the global pool");
  
              $p->cleanup_register(\&set_cleanup, [$table, 'new scoped']);
          }
  
          my @notes = $table->get('cleanup');
  
          ok t_cmp(scalar(@notes), 1, "should be 1 note");
  
          ok t_cmp($notes[0], 'new scoped');
  
          $table->clear;
      }
  
      ### custom pools + sub-pools ###
  
      # test: basic pool and sub-pool tests + implicit destroy of pool objects
      {
          {
              my ($pp, $sp) = both_pools_create_ok($table);
          }
  
          both_pools_destroy_ok($table);
  
          $table->clear;
      }
  
  
      # test: explicitly destroying a parent pool should destroy its
      # sub-pool
      {
          my ($pp, $sp) = both_pools_create_ok($table);
  
          # destroying $pp should destroy the subpool $sp too
          $pp->destroy;
  
          both_pools_destroy_ok($table);
  
          $table->clear;
      }
  
  
  
      # test: destroying a sub-pool before the parent pool
      {
          my ($pp, $sp) = both_pools_create_ok($table);
  
          $sp->destroy;
          $pp->destroy;
  
          both_pools_destroy_ok($table);
  
          $table->clear;
      }
  
  
      # test: destroying a sub-pool explicitly after the parent pool destroy
  
      # the parent pool should have already destroyed the child pool, so
      # the object is invalid
      {
          my ($pp, $sp) = both_pools_create_ok($table);
  
          $pp->destroy;
          $sp->destroy;
  
          both_pools_destroy_ok($table);
  
          $table->clear;
      }
  
  
      # test: destroying a sub-pool before the parent pool and trying to
      # call APR::Pool methods on the a subpool object which points to a
      # destroyed pool
      {
          my ($pp, $sp) = both_pools_create_ok($table);
  
          # parent pool destroys child pool
          $pp->destroy;
  
          # this should "gracefully" fail, since $sp's guts were
          # destroyed when the parent pool was destroyed
          eval { $pp = $sp->parent_get };
          ok t_cmp($@,
                   qr/invalid pool object/,
                   "parent pool destroys child pool");
  
          # since pool $sp now contains 0 pointer, if we try to make a
          # new pool out of it, it's the same as APR->new (i.e. it'll
          # use the global top level pool for it), so the resulting pool
          # should have an ancestry length of exactly 1
          my $ssp = $sp->new;
          ok t_cmp(ancestry_count($ssp), 1,
                   "a new pool has one ancestor: the global pool");
  
  
          both_pools_destroy_ok($table);
  
          $table->clear;
      }
  
      # test: make sure that one pool won't destroy/affect another pool,
      # which happened to be allocated at the same memory address after
      # the pointer to the first pool was destroyed
      {
          my $pp2;
          {
              my $pp = APR::Pool->new;
              $pp->destroy;
              # $pp2 ideally should take the exact place of apr_pool
              # previously pointed to by $pp
              $pp2 = APR::Pool->new;
              # $pp object didn't go away yet (it'll when exiting this
              # scope). in the previous implementation, $pp will be
              # destroyed second time on the exit of the scope and it
              # could happen to work, because $pp2 pointer has allocated
              # exactly the same address. and if so it would have killed
              # the pool that $pp2 points to
  
              # this should "gracefully" fail, since $pp's guts were
              # destroyed when the parent pool was destroyed
              # must make sure that it won't try to hijack the new pool
              # $pp2 that (hopefully) took over $pp's place
              eval { $pp->parent_get };
              ok t_cmp($@,
                       qr/invalid pool object/,
                       "a dead pool is a dead pool");
          }
  
          # next make sure that $pp2's pool is still alive
          $pp2->cleanup_register(\&set_cleanup, [$table, 'overtake']);
          $pp2->destroy;
  
          my @notes = $table->get('cleanup');
  
          ok t_cmp(scalar(@notes), 1, "should be 1 note");
          ok t_cmp($notes[0], 'overtake');
  
          $table->clear;
  
      }
  
      # test: similar to the previous test, but this time, the parent
      # pool destroys the child pool. a second allocation of a new pair
      # of the parent and child pools take over exactly the same
      # allocations. so if there are any ghost objects, they must not
      # find the other pools and use them as they own. for example they
      # could destroy the pools, and the perl objects of the pair would
      # have no idea that someone has destroyed the pools without their
      # knowledge. the previous implementation suffered from this
      # problem. the new implementation uses an SV which is stored in
      # the object and in the pool. when the pool is destroyed the SV
      # gets its IVX pointer set to 0, which affects any perl object
      # that is a ref to that SV. so once an apr pool is destroyed all
      # perl objects pointing to it get automatically invalidated and
      # there is no risk of hijacking newly created pools that happen to
      # be at the same memory address.
  
      {
          my ($pp2, $sp2);
          {
              my $pp = APR::Pool->new;
              my $sp = $pp->new;
              # parent destroys $sp
              $pp->destroy;
  
              # hopefully these pool will take over the $pp and $sp
              # allocations
              ($pp2, $sp2) = both_pools_create_ok($table);
          }
  
          # $pp and $sp shouldn't have triggered any cleanups
          my @notes = $table->get('cleanup');
          ok t_cmp(scalar(@notes), 0, "should be 0 notes");
          $table->clear;
  
          # parent pool destroys child pool
          $pp2->destroy;
  
          both_pools_destroy_ok($table);
  
          $table->clear;
      }
  
      # test: only when the last references to the pool object is gone
      # it should get destroyed
      {
  
          my $cp;
  
          {
              my $sp = APR::Pool->new();
  
              $sp->cleanup_register(\&set_cleanup, [$table, 'several references']);
  
              $cp = $sp;
              # destroy of $sp shouldn't call apr_pool_destroy, because
              # $cp still references to it
          }
  
          my @notes = $table->get('cleanup');
          ok t_cmp(scalar(@notes), 0, "should be 0 notes");
          $table->clear;
  
          # now the last copy is gone and the cleanup hooks will be called
          $cp->destroy;
  
          @notes = $table->get('cleanup');
          ok t_cmp(scalar(@notes), 1, "should be 1 note");
          ok t_cmp($notes[0], 'several references');
  
          $table->clear;
      }
      {
          # and another variation
          my $pp = APR::Pool->new();
          my $sp = $pp->new;
  
          my $gp  = $pp->parent_get;
          my $pp2 = $sp->parent_get;
  
          # parent destroys children
          $pp->destroy;
  
          # grand parent ($pool) is undestroyable (core pool)
          $gp->destroy;
  
          # now all custom pools are destroyed - $sp and $pp2 point nowhere
          $pp2->destroy;
          $sp->destroy;
  
          ok 1;
      }
  
      # cleanup_register using a function name as a callback
      {
          {
              my $p = APR::Pool->new;
              $p->cleanup_register('set_cleanup', [$table, 'function name']);
          }
  
          my @notes = $table->get('cleanup');
          ok t_cmp($notes[0], 'function name', "function name callback");
  
          $table->clear;
      }
  
      # cleanup_register using an anon sub callback
      {
          {
              my $p = APR::Pool->new;
  
              $p->cleanup_register(sub { &set_cleanup }, [$table, 'anon sub']);
          }
  
          my @notes = $table->get('cleanup');
          ok t_cmp($notes[0], 'anon sub', "anon callback");
  
          $table->clear;
      }
  
      # registered callbacks are run in reversed order LIFO
      {
          {
              my $p = APR::Pool->new;
  
              $p->cleanup_register(\&add_cleanup, [$table, 'first']);
              $p->cleanup_register(\&add_cleanup, [$table, 'second']);
          }
  
          my @notes = $table->get('cleanup');
          ok t_cmp($notes[0], 'second', "two cleanup functions");
          ok t_cmp($notes[1], 'first',  "two cleanup functions");
  
          $table->clear;
      }
  
      # undefined cleanup subs
      {
          my $p = APR::Pool->new;
          $p->cleanup_register('TestAPR::pool::some_non_existing_sub', 1);
          eval { $p->destroy };
          ok t_cmp($@,
                   qr/Undefined subroutine/,
                   "non existing function");
      }
      {
          my $p = APR::Pool->new;
          $p->cleanup_register(\&non_existing1, 1);
          eval { $p->destroy };
          ok t_cmp($@,
                   qr/Undefined subroutine/,
                   "non existing function");
      }
  
  # XXX: on windows $pool->clean, followed by $pool->destroy breaks
  # other tests. on unix it works fine.
  # 
  #    ### $p->clear ###
  #    {
  #        my ($pp, $sp) = both_pools_create_ok($table);
  #        $pp->clear;
  #        # both pools should have run their cleanups
  #        both_pools_destroy_ok($table);
  #
  #        # sub-pool $sp should be now bogus, as clear() destroys
  #        # subpools
  #        eval { $sp->parent_get };
  #        ok t_cmp($@,
  #                 qr/invalid pool object/,
  #                 "clear destroys sub pools");
  #
  #        # now we should be able to use the parent pool without
  #        # allocating it
  #        $pp->cleanup_register(\&set_cleanup, [$table, 're-using pool']);
  #        $pp->destroy;
  #
  #        my @notes = $table->get('cleanup');
  #        ok t_cmp('re-using pool', $notes[0]);
  #
  #        $table->clear;
  #    }
  
  
      # a pool can be tagged, so when doing low level apr_pool tracing
      # (when apr is compiled with -DAPR_POOL_DEBUG) it's possible to
      # grep(1) for a certain tag, so it's a useful method
      {
          my $p = APR::Pool->new;
          $p->tag("my pool");
  
          # though there is no way we can get back the value to test,
          # since there is no apr_pool_tag read accessor
          ok 1;
      }
  
  
  
  
      # other stuff
      {
          my $p = APR::Pool->new;
  
          # find some method that wants a pool object and try to pass it
          # an object that was already destroyed e.g. APR::Table::make($p, 2);
  
          # only available with -DAPR_POOL_DEBUG
          #my $num_bytes = $p->num_bytes;
          #ok $num_bytes;
  
      }
  }
  
  # returns how many ancestor generations the pool has (parent,
  # grandparent, etc.)
  sub ancestry_count {
      my $child = shift;
      my $gen = 0;
      while (my $parent = $child->parent_get) {
          # prevent possible endless loops
          die "child pool reports to be its own parent, corruption!"
              if $parent == $child;
          $gen++;
          die "child knows its parent, but the parent denies having that child"
              unless $parent->is_ancestor($child);
          $child = $parent;
      }
      return $gen;
  }
  
  sub add_cleanup {
      my $arg = shift;
      debug "adding cleanup note: $arg->[1]";
      $arg->[0]->add(cleanup => $arg->[1]);
      1;
  }
  
  sub set_cleanup {
      my $arg = shift;
      debug "setting cleanup note: $arg->[1]";
      $arg->[0]->set(cleanup => $arg->[1]);
      1;
  }
  
  # +4 tests
  sub both_pools_create_ok {
      my $table = shift;
  
      my $pp = APR::Pool->new;
  
      ok t_cmp(1, $pp->isa('APR::Pool'), "isa('APR::Pool')");
  
      ok t_cmp(1, ancestry_count($pp),
               "a new pool has one ancestor: the global pool");
  
      my $sp = $pp->new;
  
      ok t_cmp($sp->isa('APR::Pool'), 1, "isa('APR::Pool')");
  
      ok t_cmp(ancestry_count($sp), 2,
               "a subpool has 2 ancestors: the parent and global pools");
  
      $pp->cleanup_register(\&add_cleanup, [$table, 'parent']);
      $sp->cleanup_register(\&set_cleanup, [$table, 'child']);
  
      return ($pp, $sp);
  
  }
  
  # +3 tests
  sub both_pools_destroy_ok {
      my $table = shift;
      my @notes = $table->get('cleanup');
  
      ok t_cmp(scalar(@notes), 2, "should be 2 notes");
      ok t_cmp($notes[0], 'child');
      ok t_cmp($notes[1], 'parent');
  }
  
  1;
  
  
  
  1.18      +6 -448    modperl-2.0/t/response/TestAPR/pool.pm
  
  Index: pool.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/t/response/TestAPR/pool.pm,v
  retrieving revision 1.17
  retrieving revision 1.18
  diff -u -r1.17 -r1.18
  --- pool.pm	8 Jul 2004 06:06:33 -0000	1.17
  +++ pool.pm	15 Jul 2004 15:33:37 -0000	1.18
  @@ -13,10 +13,12 @@
   
   use Apache::Const -compile => 'OK';
   
  +use TestAPRlib::pool;
  +
   sub handler {
       my $r = shift;
   
  -    plan $r, tests => 69;
  +    plan $r, tests => 4 + TestAPRlib::pool::num_of_tests();
   
       ### native pools ###
   
  @@ -24,7 +26,7 @@
       {
           my $p = $r->pool;
   
  -        my $count = ancestry_count($p);
  +        my $count = TestAPRlib::pool::ancestry_count($p);
           t_debug "\$r->pool has 2 or more ancestors (found $count)";
           ok $count >= 2;
   
  @@ -45,7 +47,7 @@
           {
               my $p = $r->pool;
   
  -            my $count = ancestry_count($p);
  +            my $count = TestAPRlib::pool::ancestry_count($p);
               t_debug "\$r->pool has 2 or more ancestors (found $count)";
               ok $count >= 2;
   
  @@ -59,421 +61,11 @@
           $r->notes->clear;
       }
   
  -
  -    ### custom pools ###
  -
  -
  -    # test: explicit pool object destroy destroys the custom pool
  -    {
  -        my $p = APR::Pool->new;
  -
  -        $p->cleanup_register(\&set_cleanup, [$r, 'new destroy']);
  -
  -        ok t_cmp(ancestry_count($p), 1,
  -                 "a new pool has one ancestor: the global pool");
  -
  -        # explicity destroy the object
  -        $p->destroy;
  -
  -        my @notes = $r->notes->get('cleanup');
  -
  -        ok t_cmp(scalar(@notes), 1, "should be 1 note");
  -
  -        ok t_cmp($notes[0], 'new destroy');
  -
  -        $r->notes->clear;
  -    }
  -
  -
  -
  -
  -
  -    # test: lexical scoping DESTROYs the custom pool
  -    {
  -        {
  -            my $p = APR::Pool->new;
  -
  -            ok t_cmp(ancestry_count($p), 1,
  -                 "a new pool has one ancestor: the global pool");
  -
  -            $p->cleanup_register(\&set_cleanup, [$r, 'new scoped']);
  -        }
  -
  -        my @notes = $r->notes->get('cleanup');
  -
  -        ok t_cmp(scalar(@notes), 1, "should be 1 note");
  -
  -        ok t_cmp($notes[0], 'new scoped');
  -
  -        $r->notes->clear;
  -    }
  -
  -    ### custom pools + sub-pools ###
  -
  -    # test: basic pool and sub-pool tests + implicit destroy of pool objects
  -    {
  -        {
  -            my ($pp, $sp) = both_pools_create_ok($r);
  -        }
  -
  -        both_pools_destroy_ok($r);
  -
  -        $r->notes->clear;
  -    }
  -
  -
  -    # test: explicitly destroying a parent pool should destroy its
  -    # sub-pool
  -    {
  -        my ($pp, $sp) = both_pools_create_ok($r);
  -
  -        # destroying $pp should destroy the subpool $sp too
  -        $pp->destroy;
  -
  -        both_pools_destroy_ok($r);
  -
  -        $r->notes->clear;
  -    }
  -
  -
  -
  -    # test: destroying a sub-pool before the parent pool
  -    {
  -        my ($pp, $sp) = both_pools_create_ok($r);
  -
  -        $sp->destroy;
  -        $pp->destroy;
  -
  -        both_pools_destroy_ok($r);
  -
  -        $r->notes->clear;
  -    }
  -
  -
  -    # test: destroying a sub-pool explicitly after the parent pool destroy
  -
  -    # the parent pool should have already destroyed the child pool, so
  -    # the object is invalid
  -    {
  -        my ($pp, $sp) = both_pools_create_ok($r);
  -
  -        $pp->destroy;
  -        $sp->destroy;
  -
  -        both_pools_destroy_ok($r);
  -
  -        $r->notes->clear;
  -    }
  -
  -
  -    # test: destroying a sub-pool before the parent pool and trying to
  -    # call APR::Pool methods on the a subpool object which points to a
  -    # destroyed pool
  -    {
  -        my ($pp, $sp) = both_pools_create_ok($r);
  -
  -        # parent pool destroys child pool
  -        $pp->destroy;
  -
  -        # this should "gracefully" fail, since $sp's guts were
  -        # destroyed when the parent pool was destroyed
  -        eval { $pp = $sp->parent_get };
  -        ok t_cmp($@,
  -                 qr/invalid pool object/,
  -                 "parent pool destroys child pool");
  -
  -        # since pool $sp now contains 0 pointer, if we try to make a
  -        # new pool out of it, it's the same as APR->new (i.e. it'll
  -        # use the global top level pool for it), so the resulting pool
  -        # should have an ancestry length of exactly 1
  -        my $ssp = $sp->new;
  -        ok t_cmp(ancestry_count($ssp), 1,
  -                 "a new pool has one ancestor: the global pool");
  -
  -
  -        both_pools_destroy_ok($r);
  -
  -        $r->notes->clear;
  -    }
  -
  -    # test: make sure that one pool won't destroy/affect another pool,
  -    # which happened to be allocated at the same memory address after
  -    # the pointer to the first pool was destroyed
  -    {
  -        my $pp2;
  -        {
  -            my $pp = APR::Pool->new;
  -            $pp->destroy;
  -            # $pp2 ideally should take the exact place of apr_pool
  -            # previously pointed to by $pp
  -            $pp2 = APR::Pool->new;
  -            # $pp object didn't go away yet (it'll when exiting this
  -            # scope). in the previous implementation, $pp will be
  -            # destroyed second time on the exit of the scope and it
  -            # could happen to work, because $pp2 pointer has allocated
  -            # exactly the same address. and if so it would have killed
  -            # the pool that $pp2 points to
  -
  -            # this should "gracefully" fail, since $pp's guts were
  -            # destroyed when the parent pool was destroyed
  -            # must make sure that it won't try to hijack the new pool
  -            # $pp2 that (hopefully) took over $pp's place
  -            eval { $pp->parent_get };
  -            ok t_cmp($@,
  -                     qr/invalid pool object/,
  -                     "a dead pool is a dead pool");
  -        }
  -
  -        # next make sure that $pp2's pool is still alive
  -        $pp2->cleanup_register(\&set_cleanup, [$r, 'overtake']);
  -        $pp2->destroy;
  -
  -        my @notes = $r->notes->get('cleanup');
  -
  -        ok t_cmp(scalar(@notes), 1, "should be 1 note");
  -        ok t_cmp($notes[0], 'overtake');
  -
  -        $r->notes->clear;
  -
  -    }
  -
  -    # test: similar to the previous test, but this time, the parent
  -    # pool destroys the child pool. a second allocation of a new pair
  -    # of the parent and child pools take over exactly the same
  -    # allocations. so if there are any ghost objects, they must not
  -    # find the other pools and use them as they own. for example they
  -    # could destroy the pools, and the perl objects of the pair would
  -    # have no idea that someone has destroyed the pools without their
  -    # knowledge. the previous implementation suffered from this
  -    # problem. the new implementation uses an SV which is stored in
  -    # the object and in the pool. when the pool is destroyed the SV
  -    # gets its IVX pointer set to 0, which affects any perl object
  -    # that is a ref to that SV. so once an apr pool is destroyed all
  -    # perl objects pointing to it get automatically invalidated and
  -    # there is no risk of hijacking newly created pools that happen to
  -    # be at the same memory address.
  -
  -    {
  -        my ($pp2, $sp2);
  -        {
  -            my $pp = APR::Pool->new;
  -            my $sp = $pp->new;
  -            # parent destroys $sp
  -            $pp->destroy;
  -
  -            # hopefully these pool will take over the $pp and $sp
  -            # allocations
  -            ($pp2, $sp2) = both_pools_create_ok($r);
  -        }
  -
  -        # $pp and $sp shouldn't have triggered any cleanups
  -        my @notes = $r->notes->get('cleanup');
  -        ok t_cmp(scalar(@notes), 0, "should be 0 notes");
  -        $r->notes->clear;
  -
  -        # parent pool destroys child pool
  -        $pp2->destroy;
  -
  -        both_pools_destroy_ok($r);
  -
  -        $r->notes->clear;
  -    }
  -
  -    # test: only when the last references to the pool object is gone
  -    # it should get destroyed
  -    {
  -
  -        my $cp;
  -
  -        {
  -            my $sp = $r->pool->new;
  -
  -            $sp->cleanup_register(\&set_cleanup, [$r, 'several references']);
  -
  -            $cp = $sp;
  -            # destroy of $sp shouldn't call apr_pool_destroy, because
  -            # $cp still references to it
  -        }
  -
  -        my @notes = $r->notes->get('cleanup');
  -        ok t_cmp(scalar(@notes), 0, "should be 0 notes");
  -        $r->notes->clear;
  -
  -        # now the last copy is gone and the cleanup hooks will be called
  -        $cp->destroy;
  -
  -        @notes = $r->notes->get('cleanup');
  -        ok t_cmp(scalar(@notes), 1, "should be 1 note");
  -        ok t_cmp($notes[0], 'several references');
  -
  -        $r->notes->clear;
  -    }
  -    {
  -        # and another variation
  -        my $pp = $r->pool->new;
  -        my $sp = $pp->new;
  -
  -        my $gp  = $pp->parent_get;
  -        my $pp2 = $sp->parent_get;
  -
  -        # parent destroys children
  -        $pp->destroy;
  -
  -        # grand parent ($r->pool) is undestroyable (core pool)
  -        $gp->destroy;
  -
  -        # now all custom pools are destroyed - $sp and $pp2 point nowhere
  -        $pp2->destroy;
  -        $sp->destroy;
  -
  -        ok 1;
  -    }
  -
  -    # cleanup_register using a function name as a callback
  -    {
  -        {
  -            my $p = APR::Pool->new;
  -            $p->cleanup_register('set_cleanup', [$r, 'function name']);
  -        }
  -
  -        my @notes = $r->notes->get('cleanup');
  -        ok t_cmp($notes[0], 'function name', "function name callback");
  -
  -        $r->notes->clear;
  -    }
  -
  -    # cleanup_register using an anon sub callback
  -    {
  -        {
  -            my $p = APR::Pool->new;
  -
  -            $p->cleanup_register(sub { &set_cleanup }, [$r, 'anon sub']);
  -        }
  -
  -        my @notes = $r->notes->get('cleanup');
  -        ok t_cmp($notes[0], 'anon sub', "anon callback");
  -
  -        $r->notes->clear;
  -    }
  -
  -    # registered callbacks are run in reversed order LIFO
  -    {
  -        {
  -            my $p = APR::Pool->new;
  -
  -            $p->cleanup_register(\&add_cleanup, [$r, 'first']);
  -            $p->cleanup_register(\&add_cleanup, [$r, 'second']);
  -        }
  -
  -        my @notes = $r->notes->get('cleanup');
  -        ok t_cmp($notes[0], 'second', "two cleanup functions");
  -        ok t_cmp($notes[1], 'first',  "two cleanup functions");
  -
  -        $r->notes->clear;
  -    }
  -
  -    # undefined cleanup subs
  -    {
  -        my $p = APR::Pool->new;
  -        $p->cleanup_register('TestAPR::pool::some_non_existing_sub', 1);
  -        eval { $p->destroy };
  -        ok t_cmp($@,
  -                 qr/Undefined subroutine/,
  -                 "non existing function");
  -    }
  -    {
  -        my $p = APR::Pool->new;
  -        $p->cleanup_register(\&non_existing1, 1);
  -        eval { $p->destroy };
  -        ok t_cmp($@,
  -                 qr/Undefined subroutine/,
  -                 "non existing function");
  -    }
  -
  -# XXX: on windows $pool->clean, followed by $pool->destroy breaks
  -# other tests. on unix it works fine.
  -# 
  -#    ### $p->clear ###
  -#    {
  -#        my ($pp, $sp) = both_pools_create_ok($r);
  -#        $pp->clear;
  -#        # both pools should have run their cleanups
  -#        both_pools_destroy_ok($r);
  -#
  -#        # sub-pool $sp should be now bogus, as clear() destroys
  -#        # subpools
  -#        eval { $sp->parent_get };
  -#        ok t_cmp($@,
  -#                 qr/invalid pool object/,
  -#                 "clear destroys sub pools");
  -#
  -#        # now we should be able to use the parent pool without
  -#        # allocating it
  -#        $pp->cleanup_register(\&set_cleanup, [$r, 're-using pool']);
  -#        $pp->destroy;
  -#
  -#        my @notes = $r->notes->get('cleanup');
  -#        ok t_cmp('re-using pool', $notes[0]);
  -#
  -#        $r->notes->clear;
  -#    }
  -
  -
  -    # a pool can be tagged, so when doing low level apr_pool tracing
  -    # (when apr is compiled with -DAPR_POOL_DEBUG) it's possible to
  -    # grep(1) for a certain tag, so it's a useful method
  -    {
  -        my $p = APR::Pool->new;
  -        $p->tag("my pool");
  -
  -        # though there is no way we can get back the value to test,
  -        # since there is no apr_pool_tag read accessor
  -        ok 1;
  -    }
  -
  -
  -
  -
  -    # other stuff
  -    {
  -        my $p = APR::Pool->new;
  -
  -        # find some method that wants a pool object and try to pass it
  -        # an object that was already destroyed e.g. APR::Table::make($p, 2);
  -
  -        # only available with -DAPR_POOL_DEBUG
  -        #my $num_bytes = $p->num_bytes;
  -        #ok $num_bytes;
  -
  -    }
  +    TestAPRlib::pool::test();
   
       Apache::OK;
   }
   
  -# returns how many ancestor generations the pool has (parent,
  -# grandparent, etc.)
  -sub ancestry_count {
  -    my $child = shift;
  -    my $gen = 0;
  -    while (my $parent = $child->parent_get) {
  -        # prevent possible endless loops
  -        die "child pool reports to be its own parent, corruption!"
  -            if $parent == $child;
  -        $gen++;
  -        die "child knows its parent, but the parent denies having that child"
  -            unless $parent->is_ancestor($child);
  -        $child = $parent;
  -    }
  -    return $gen;
  -}
  -
  -sub add_cleanup {
  -    my $arg = shift;
  -    debug "adding cleanup note: $arg->[1]";
  -    $arg->[0]->notes->add(cleanup => $arg->[1]);
  -    1;
  -}
  -
   sub set_cleanup {
       my $arg = shift;
       debug "setting cleanup note: $arg->[1]";
  @@ -481,39 +73,5 @@
       1;
   }
   
  -# +4 tests
  -sub both_pools_create_ok {
  -    my $r = shift;
  -
  -    my $pp = APR::Pool->new;
  -
  -    ok t_cmp(1, $pp->isa('APR::Pool'), "isa('APR::Pool')");
  -
  -    ok t_cmp(1, ancestry_count($pp),
  -             "a new pool has one ancestor: the global pool");
  -
  -    my $sp = $pp->new;
  -
  -    ok t_cmp($sp->isa('APR::Pool'), 1, "isa('APR::Pool')");
  -
  -    ok t_cmp(ancestry_count($sp), 2,
  -             "a subpool has 2 ancestors: the parent and global pools");
  -
  -    $pp->cleanup_register(\&add_cleanup, [$r, 'parent']);
  -    $sp->cleanup_register(\&set_cleanup, [$r, 'child']);
  -
  -    return ($pp, $sp);
  -
  -}
  -
  -# +3 tests
  -sub both_pools_destroy_ok {
  -    my $r = shift;
  -    my @notes = $r->notes->get('cleanup');
  -
  -    ok t_cmp(scalar(@notes), 2, "should be 2 notes");
  -    ok t_cmp($notes[0], 'child');
  -    ok t_cmp($notes[1], 'parent');
  -}
   
   1;
  
  
  

Mime
View raw message