home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / CacheTester.pm < prev    next >
Encoding:
Perl POD Document  |  2003-04-15  |  12.5 KB  |  663 lines
  1. ######################################################################
  2. # $Id: CacheTester.pm,v 1.21 2003/04/15 14:46:17 dclinton Exp $
  3. # Copyright (C) 2001-2003 DeWitt Clinton  All Rights Reserved
  4. #
  5. # Software distributed under the License is distributed on an "AS
  6. # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
  7. # implied. See the License for the specific language governing
  8. # rights and limitations under the License.
  9. ######################################################################
  10.  
  11. package Cache::CacheTester;
  12.  
  13. use strict;
  14. use Cache::BaseCacheTester;
  15. use Cache::Cache;
  16. use Error qw( :try );
  17.  
  18. use vars qw( @ISA $EXPIRES_DELAY );
  19.  
  20. @ISA = qw ( Cache::BaseCacheTester );
  21.  
  22. $EXPIRES_DELAY = 2;
  23. $Error::Debug = 1;
  24.  
  25. sub test
  26. {
  27.   my ( $self, $cache ) = @_;
  28.  
  29.   try
  30.   {
  31.     $cache->Clear( );
  32.     $self->_test_one( $cache );
  33.     $self->_test_two( $cache );
  34.     $self->_test_three( $cache );
  35.     $self->_test_four( $cache );
  36.     $self->_test_five( $cache );
  37.     $self->_test_six( $cache );
  38.     $self->_test_seven( $cache );
  39.     $self->_test_eight( $cache );
  40.     $self->_test_nine( $cache );
  41.     $self->_test_ten( $cache );
  42.     $self->_test_eleven( $cache );
  43.     $self->_test_twelve( $cache );
  44.     $self->_test_thirteen( $cache );
  45.     $self->_test_fourteen( $cache );
  46.     $self->_test_fifteen( $cache );
  47.     $self->_test_sixteen( $cache );
  48.     $self->_test_seventeen( $cache );
  49.   }
  50.   catch Error with
  51.   {
  52.     my $error = shift;
  53.  
  54.     print STDERR "\nError:\n";
  55.     print STDERR $error->stringify( ) . "\n";
  56.     print STDERR $error->stacktrace( ) . "\n";
  57.     print STDERR "\n";
  58.   }
  59. }
  60.  
  61.  
  62. # Test the getting, setting, and removal of a scalar
  63.  
  64. sub _test_one
  65. {
  66.   my ( $self, $cache ) = @_;
  67.  
  68.   $cache or
  69.     croak( "cache required" );
  70.  
  71.   my $key = 'Test Key';
  72.  
  73.   my $value = 'Test Value';
  74.  
  75.   $cache->set( $key, $value );
  76.  
  77.   my $fetched_value = $cache->get( $key );
  78.  
  79.   ( $fetched_value eq $value ) ?
  80.     $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  81.  
  82.   $cache->remove( $key );
  83.  
  84.   my $fetched_removed_value = $cache->get( $key );
  85.  
  86.   ( not defined $fetched_removed_value ) ?
  87.     $self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' );
  88. }
  89.  
  90.  
  91. # Test the getting, setting, and removal of a list
  92.  
  93. sub _test_two
  94. {
  95.   my ( $self, $cache ) = @_;
  96.  
  97.   $cache or
  98.     croak( "cache required" );
  99.  
  100.   my $key = 'Test Key';
  101.  
  102.   my @value_list = ( 'One', 'Two', 'Three' );
  103.  
  104.   $cache->set( $key, \@value_list );
  105.  
  106.   my $fetched_value_list_ref = $cache->get( $key );
  107.  
  108.   if ( ( $fetched_value_list_ref->[0] eq 'One' ) and
  109.        ( $fetched_value_list_ref->[1] eq 'Two' ) and
  110.        ( $fetched_value_list_ref->[2] eq 'Three' ) )
  111.   {
  112.     $self->ok( );
  113.   }
  114.   else
  115.   {
  116.     $self->not_ok( 'fetched list does not match set list' );
  117.   }
  118.  
  119.   $cache->remove( $key );
  120.  
  121.   my $fetched_removed_value = $cache->get( $key );
  122.  
  123.   ( not defined $fetched_removed_value ) ?
  124.     $self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' );
  125. }
  126.  
  127.  
  128. # Test the getting, setting, and removal of a blessed object
  129.  
  130. sub _test_three
  131. {
  132.   my ( $self, $cache ) = @_;
  133.  
  134.   $cache or
  135.     croak( "cache required" );
  136.  
  137.   my $key = 'Test Key';
  138.  
  139.   my $value = 'Test Value';
  140.  
  141.   $cache->set( $key, $value );
  142.  
  143.   my $cache_key = 'Cache Key';
  144.  
  145.   $cache->set( $cache_key, $cache );
  146.  
  147.   my $fetched_cache = $cache->get( $cache_key );
  148.  
  149.   ( defined $fetched_cache ) ?
  150.     $self->ok( ) : $self->not_ok( 'defined $fetched_cache' );
  151.  
  152.   my $fetched_value = $fetched_cache->get( $key );
  153.  
  154.   ( $fetched_value eq $value ) ?
  155.     $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  156. }
  157.  
  158.  
  159. # Test the expiration of an object
  160.  
  161. sub _test_four
  162. {
  163.   my ( $self, $cache ) = @_;
  164.  
  165.   my $expires_in = $EXPIRES_DELAY;
  166.  
  167.   my $key = 'Test Key';
  168.  
  169.   my $value = 'Test Value';
  170.  
  171.   $cache->set( $key, $value, $expires_in );
  172.  
  173.   my $fetched_value = $cache->get( $key );
  174.  
  175.   ( $fetched_value eq $value ) ?
  176.     $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  177.  
  178.   sleep( $EXPIRES_DELAY + 1 );
  179.  
  180.   my $fetched_expired_value = $cache->get( $key );
  181.  
  182.   ( not defined $fetched_expired_value ) ?
  183.     $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' );
  184. }
  185.  
  186.  
  187.  
  188. # Test that caches make deep copies of values
  189.  
  190. sub _test_five
  191. {
  192.   my ( $self, $cache ) = @_;
  193.  
  194.   $cache or
  195.     croak( "cache required" );
  196.  
  197.   my $key = 'Test Key';
  198.  
  199.   my @value_list = ( 'One', 'Two', 'Three' );
  200.  
  201.   $cache->set( $key, \@value_list );
  202.  
  203.   @value_list = ( );
  204.  
  205.   my $fetched_value_list_ref = $cache->get( $key );
  206.  
  207.   if ( ( $fetched_value_list_ref->[0] eq 'One' ) and
  208.        ( $fetched_value_list_ref->[1] eq 'Two' ) and
  209.        ( $fetched_value_list_ref->[2] eq 'Three' ) )
  210.   {
  211.     $self->ok( );
  212.   }
  213.   else
  214.   {
  215.     $self->not_ok( 'fetched deep list does not match set deep list' );
  216.   }
  217. }
  218.  
  219.  
  220.  
  221. # Test clearing a cache
  222.  
  223. sub _test_six
  224. {
  225.   my ( $self, $cache ) = @_;
  226.  
  227.   $cache or
  228.     croak( "cache required" );
  229.  
  230.   my $key = 'Test Key';
  231.  
  232.   my $value = 'Test Value';
  233.  
  234.   $cache->set( $key, $value );
  235.  
  236.   $cache->clear( );
  237.  
  238.   my $fetched_cleared_value = $cache->get( $key );
  239.  
  240.   ( not defined $fetched_cleared_value ) ?
  241.     $self->ok( ) : $self->not_ok( 'not defined $fetched_cleared_value' );
  242. }
  243.  
  244.  
  245. # Test sizing of the cache
  246.  
  247. sub _test_seven
  248. {
  249.   my ( $self, $cache ) = @_;
  250.  
  251.   my $empty_size = $cache->size( );
  252.  
  253.   ( $empty_size == 0 ) ?
  254.     $self->ok( ) : $self->not_ok( '$empty_size == 0' );
  255.  
  256.   my $first_key = 'First Test Key';
  257.  
  258.   my $value = 'Test Value';
  259.  
  260.   $cache->set( $first_key, $value );
  261.  
  262.   my $first_size = $cache->size( );
  263.  
  264.   ( $first_size > $empty_size ) ?
  265.     $self->ok( ) : $self->not_ok( '$first_size > $empty_size' );
  266.  
  267.   my $second_key = 'Second Test Key';
  268.  
  269.   $cache->set( $second_key, $value );
  270.  
  271.   my $second_size = $cache->size( );
  272.  
  273.   ( $second_size > $first_size ) ?
  274.     $self->ok( ) : $self->not_ok( '$second_size > $first_size' );
  275. }
  276.  
  277.  
  278. # Test purging the cache
  279.  
  280. sub _test_eight
  281. {
  282.   my ( $self, $cache ) = @_;
  283.  
  284.   $cache->clear( );
  285.  
  286.   my $empty_size = $cache->size( );
  287.  
  288.   ( $empty_size == 0 ) ?
  289.     $self->ok( ) : $self->not_ok( '$empty_size == 0' );
  290.  
  291.   my $expires_in = $EXPIRES_DELAY;
  292.  
  293.   my $key = 'Test Key';
  294.  
  295.   my $value = 'Test Value';
  296.  
  297.   $cache->set( $key, $value, $expires_in );
  298.  
  299.   my $pre_purge_size = $cache->size( );
  300.  
  301.   ( $pre_purge_size > $empty_size ) ?
  302.     $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
  303.  
  304.   sleep( $EXPIRES_DELAY + 1 );
  305.  
  306.   $cache->purge( );
  307.  
  308.   my $post_purge_size = $cache->size( );
  309.  
  310.   ( $post_purge_size == $empty_size ) ?
  311.     $self->ok( ) : $self->not_ok( '$post_purge_size == $empty_size' );
  312. }
  313.  
  314.  
  315. # Test the getting, setting, and removal of a scalar across cache instances
  316.  
  317. sub _test_nine
  318. {
  319.   my ( $self, $cache1 ) = @_;
  320.  
  321.   $cache1 or
  322.     croak( "cache required" );
  323.  
  324.   my $cache2 = $cache1->new( ) or
  325.     croak( "Couldn't construct new cache" );
  326.  
  327.   my $key = 'Test Key';
  328.  
  329.   my $value = 'Test Value';
  330.  
  331.   $cache1->set( $key, $value );
  332.  
  333.   my $fetched_value = $cache2->get( $key );
  334.  
  335.   ( $fetched_value eq $value ) ?
  336.     $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  337. }
  338.  
  339.  
  340. # Test Clear() and Size() as instance methods
  341.  
  342. sub _test_ten
  343. {
  344.   my ( $self, $cache ) = @_;
  345.  
  346.   $cache or
  347.     croak( "cache required" );
  348.  
  349.   my $key = 'Test Key';
  350.  
  351.   my $value = 'Test Value';
  352.  
  353.   $cache->set( $key, $value );
  354.  
  355.   my $full_size = $cache->Size( );
  356.  
  357.   ( $full_size > 0 ) ?
  358.     $self->ok( ) : $self->not_ok( '$full_size > 0' );
  359.  
  360.   $cache->Clear( );
  361.  
  362.   my $empty_size = $cache->Size( );
  363.  
  364.   ( $empty_size == 0 ) ?
  365.     $self->ok( ) : $self->not_ok( '$empty_size == 0' );
  366. }
  367.  
  368.  
  369. # Test Purge(), Clear(), and Size() as instance methods
  370.  
  371. sub _test_eleven
  372. {
  373.   my ( $self, $cache ) = @_;
  374.  
  375.   $cache->Clear( );
  376.  
  377.   my $empty_size = $cache->Size( );
  378.  
  379.   ( $empty_size == 0 ) ?
  380.     $self->ok( ) : $self->not_ok( '$empty_size == 0' );
  381.  
  382.   my $expires_in = $EXPIRES_DELAY;
  383.  
  384.   my $key = 'Test Key';
  385.  
  386.   my $value = 'Test Value';
  387.  
  388.   $cache->set( $key, $value, $expires_in );
  389.  
  390.   my $pre_purge_size = $cache->Size( );
  391.  
  392.   ( $pre_purge_size > $empty_size ) ?
  393.     $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
  394.  
  395.   sleep( $EXPIRES_DELAY + 1 );
  396.  
  397.   $cache->Purge( );
  398.  
  399.   my $purged_object = $cache->get_object( $key );
  400.  
  401.   ( not defined $purged_object ) ?
  402.     $self->ok( ) : $self->not_ok( 'not defined $purged_object' );
  403. }
  404.  
  405.  
  406. # Test Purge(), Clear(), and Size() as static methods
  407.  
  408. sub _test_twelve
  409. {
  410.   my ( $self, $cache ) = @_;
  411.  
  412.   my $class = ref $cache or
  413.     croak( "Couldn't get ref \$cache" );
  414.  
  415.   no strict 'refs';
  416.  
  417.   &{"${class}::Clear"}( );
  418.  
  419.   my $empty_size = &{"${class}::Size"}( );
  420.  
  421.   ( $empty_size == 0 ) ?
  422.     $self->ok( ) : $self->not_ok( '$empty_size == 0' );
  423.  
  424.   my $expires_in = $EXPIRES_DELAY;
  425.  
  426.   my $key = 'Test Key';
  427.  
  428.   my $value = 'Test Value';
  429.  
  430.   $cache->set( $key, $value, $expires_in );
  431.  
  432.   my $pre_purge_size = &{"${class}::Size"}( );
  433.  
  434.   ( $pre_purge_size > $empty_size ) ?
  435.     $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
  436.  
  437.   sleep( $EXPIRES_DELAY + 1 );
  438.  
  439.   &{"${class}::Purge"}( );
  440.  
  441.   my $purged_object = $cache->get_object( $key );
  442.  
  443.   ( not defined $purged_object ) ?
  444.     $self->ok( ) : $self->not_ok( 'not defined $purged_object' );
  445.  
  446.   use strict;
  447. }
  448.  
  449.  
  450.  
  451. # Test the expiration of an object with extended syntax
  452.  
  453. sub _test_thirteen
  454. {
  455.   my ( $self, $cache ) = @_;
  456.  
  457.   my $expires_in = $EXPIRES_DELAY;
  458.  
  459.   my $key = 'Test Key';
  460.  
  461.   my $value = 'Test Value';
  462.  
  463.   $cache->set( $key, $value, $expires_in );
  464.  
  465.   my $fetched_value = $cache->get( $key );
  466.  
  467.   ( $fetched_value eq $value ) ?
  468.     $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  469.  
  470.   sleep( $EXPIRES_DELAY + 1 );
  471.  
  472.   my $fetched_expired_value = $cache->get( $key );
  473.  
  474.   ( not defined $fetched_expired_value ) ?
  475.     $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' );
  476. }
  477.  
  478.  
  479. # test the get_keys method
  480.  
  481. sub _test_fourteen
  482. {
  483.   my ( $self, $cache ) = @_;
  484.  
  485.   $cache->Clear( );
  486.  
  487.   my $empty_size = $cache->Size( );
  488.  
  489.   ( $empty_size == 0 ) ?
  490.     $self->ok( ) : $self->not_ok( '$empty_size == 0' );
  491.  
  492.   my @keys = sort ( 'John', 'Paul', 'Ringo', 'George' );
  493.  
  494.   my $value = 'Test Value';
  495.  
  496.   foreach my $key ( @keys )
  497.   {
  498.     $cache->set( $key, $value );
  499.   }
  500.  
  501.   my @cached_keys = sort $cache->get_keys( );
  502.  
  503.   my $arrays_equal = Arrays_Are_Equal( \@keys, \@cached_keys );
  504.  
  505.   ( $arrays_equal == 1 ) ?
  506.     $self->ok( ) : $self->not_ok( '$arrays_equal == 1' );
  507. }
  508.  
  509.  
  510. # test the auto_purge on set functionality
  511.  
  512. sub _test_fifteen
  513. {
  514.   my ( $self, $cache ) = @_;
  515.  
  516.   $cache->Clear( );
  517.  
  518.   my $expires_in = $EXPIRES_DELAY;
  519.  
  520.   $cache->set_auto_purge_interval( $expires_in );
  521.  
  522.   $cache->set_auto_purge_on_set( 1 );
  523.  
  524.   my $key = 'Test Key';
  525.  
  526.   my $value = 'Test Value';
  527.  
  528.   $cache->set( $key, $value, $expires_in );
  529.  
  530.   my $fetched_value = $cache->get( $key );
  531.  
  532.   ( $fetched_value eq $value ) ?
  533.     $self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
  534.  
  535.   sleep( $EXPIRES_DELAY + 1 );
  536.  
  537.   $cache->set( "Trigger auto_purge", "Empty" );
  538.  
  539.   my $fetched_expired_object = $cache->get_object( $key );
  540.  
  541.   ( not defined $fetched_expired_object ) ?
  542.     $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_object' );
  543.  
  544.   $cache->Clear( );
  545. }
  546.  
  547.  
  548.  
  549. # test the auto_purge_interval functionality
  550.  
  551. sub _test_sixteen
  552. {
  553.   my ( $self, $cache ) = @_;
  554.  
  555.   my $expires_in = $EXPIRES_DELAY;
  556.  
  557.   eval
  558.   {
  559.     $cache = $cache->new( { 'auto_purge_interval' => $expires_in } );
  560.   };
  561.  
  562.   ( not defined @$ ) ?
  563.     $self->ok( ) : $self->not_ok( "couldn't create autopurge cache" );
  564. }
  565.  
  566.  
  567. # test the get_namespaces method
  568.  
  569. sub _test_seventeen
  570. {
  571.   my ( $self, $cache ) = @_;
  572.  
  573.   $cache->set( 'foo', 'bar' );
  574.  
  575.   if ( Arrays_Are_Equal( [ sort( $cache->get_namespaces( ) ) ],
  576.                          [ sort( 'Default', '__AUTO_PURGE__' ) ] ) )
  577.   {
  578.     $self->ok( );
  579.   }
  580.   else
  581.   {
  582.     $self->not_ok( "get_namespaces returned the wrong namespaces" );
  583.   }
  584.  
  585.   $cache->Clear( );
  586. }
  587.  
  588.  
  589.  
  590. sub Arrays_Are_Equal
  591. {
  592.   my ( $first_array_ref, $second_array_ref ) = @_;
  593.  
  594.   local $^W = 0;  # silence spurious -w undef complaints
  595.  
  596.   return 0 unless @$first_array_ref == @$second_array_ref;
  597.  
  598.   for (my $i = 0; $i < @$first_array_ref; $i++)
  599.   {
  600.     return 0 if $first_array_ref->[$i] ne $second_array_ref->[$i];
  601.   }
  602.  
  603.   return 1;
  604. }
  605.  
  606.  
  607. 1;
  608.  
  609.  
  610. __END__
  611.  
  612. =pod
  613.  
  614. =head1 NAME
  615.  
  616. Cache::CacheTester -- a class for regression testing caches
  617.  
  618. =head1 DESCRIPTION
  619.  
  620. The CacheTester is used to verify that a cache implementation honors
  621. its contract.
  622.  
  623. =head1 SYNOPSIS
  624.  
  625.   use Cache::MemoryCache;
  626.   use Cache::CacheTester;
  627.  
  628.   my $cache = new Cache::MemoryCache( );
  629.  
  630.   my $cache_tester = new Cache::CacheTester( 1 );
  631.  
  632.   $cache_tester->test( $cache );
  633.  
  634. =head1 METHODS
  635.  
  636. =over
  637.  
  638. =item B<new( $initial_count )>
  639.  
  640. Construct a new CacheTester object, with the counter starting at
  641. I<$initial_count>.
  642.  
  643. =item B<test( )>
  644.  
  645. Run the tests.
  646.  
  647. =back
  648.  
  649. =head1 SEE ALSO
  650.  
  651. Cache::Cache, Cache::BaseCacheTester
  652.  
  653. =head1 AUTHOR
  654.  
  655. Original author: DeWitt Clinton <dewitt@unto.net>
  656.  
  657. Last author:     $Author: dclinton $
  658.  
  659. Copyright (C) 2001-2003 DeWitt Clinton
  660.  
  661. =cut
  662.  
  663.