#!/usr/bin/perl -w

use strict;

use HTML::Mason::Tests;
use HTML::Mason::Tools;

# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
    print "1..0 # Skipped: flock() is not available on this system\n";
    exit;
}

# Skip if CHI not present.
eval "use CHI 0.21";
if ($@)
{
    print "1..0 # Skipped: CHI 0.21+ is not installed\n";
    exit;
}

my %chi_interp_params = (interp_params => { data_cache_api => 'chi' });

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
                                                      description => 'Test caching' );

#------------------------------------------------------------

    $group->add_support( path => 'support/cache_test',
                         component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.

<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache->get('fandango')) {
    $result = "Hello Dolly.";
    $return = $m->cache->set('fandango', $result) || '';
} else {
    $cached = 1;
}
</%init>
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'cache',
                      description => 'basic caching functionality',
                      %chi_interp_params,
                      component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
                      expect => <<'EOF',
Hello Dolly.
This was not cached.


Hello Dolly.
This was cached.


Hello Dolly.
This was cached.


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'keys',
                      description => q|test multiple keys and $m->cache->get_keys|,
                      %chi_interp_params,
                      component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
    $m->cache->set($key, $key);
}
my @keys = sort $m->cache->get_keys;
$m->print("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache->get($key) || "undefined";
    $m->print("value for $key is $value\n");
}
$m->cache->remove('foo');
$m->cache->remove('bar');
$m->print("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache->get($key) || "undefined";
    $m->print("value for $key is $value\n");
}
</%init>
EOF
                      expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
</%args>
<%init>
return if $m->cache_self;
</%init>
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self',
                      description => 'test $m->cache_self',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self, x => 1 &>
<& support/cache_self, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expires_in',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
</%args>
<%init>
return if $m->cache_self( expires_in => '3s' );
</%init>
EOF
                        );

    $group->add_test( name => 'cache_self_expires_in',
                      description => 'test that $m->cache_self respects expires_in parameter',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_expires_in, x => 1 &>
<& support/cache_self_expires_in, x => 2 &>
% sleep 5;
<& support/cache_self_expires_in, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 99
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expire_in',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
</%args>
<%init>
return if $m->cache_self( expire_in => '1s' );
</%init>
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_expire_in',
                      description => 'test that $m->cache_self respects expire_in parameter',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_expire_in, x => 1 &>
<& support/cache_self_expire_in, x => 2 &>
% sleep 5;
<& support/cache_self_expire_in, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 99
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expire_if',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
</%args>
<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );
</%init>
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_expire_if',
                      description => 'test that $m->cache_self respects expire_if parameter',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_expire_if, x => 1 &>
<& support/cache_self_expire_if, x => 2 &>
<& support/cache_self_expire_if, x => 3 &>
<& support/cache_self_expire_if, x => 4 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 3

x is 3
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_with_key',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
$key
</%args>
<%init>
return if $m->cache_self( key => $key );
</%init>
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_key',
                      description => 'test $m->cache_self with a key',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_with_key, x => 1, key => 1 &>
<& support/cache_self_with_key, x => 99, key => 99 &>
<& support/cache_self_with_key, x => 1000, key => 1 &>
EOF
                      expect => <<'EOF',
x is 1

x is 99

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_and_die',
                          component => <<'EOF',
<%init>
return if $m->cache_self;
die "argh!";
</%init>
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_error',
                      description => 'test $m->cache_self with an error to make sure errors are propogated',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_and_die, x => 1, key => 1 &>
EOF
                      expect_error => qr/argh! at .*/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_scomp',
                      description => 'make sure that $m->cache_self cooperates with $m->scomp',
                      %chi_interp_params,
                      component => <<'EOF',
<% $m->scomp( 'support/cache_self', x => 1 ) %>
<% $m->scomp( 'support/cache_self', x => 99 ) %>
EOF
                      expect => <<'EOF',
x is 1

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_filtered',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
$key => 1
</%args>
<%init>
return if $m->cache_self( key => $key );
</%init>
<%filter>
$_ = uc $_;
$_ .= ' filtered';
</%filter>
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered',
                      description => 'test $m->cache_self with a filter block',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_filtered, x => 1 &>
<& support/cache_self_filtered, x => 99 &>
EOF
                      expect => <<'EOF',
X IS 1
 filtered
X IS 1
 filtered
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered_scomp',
                      description => 'test $m->cache_self with a filter block callled via $m->scomp',
                      %chi_interp_params,
                      component => <<'EOF',
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 1 ) %>
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 99 ) %>
EOF
                      expect => <<'EOF',
X IS 1
 filtered
X IS 1
 filtered
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_filtered_2',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
</%args>
<%init>
return if $m->cache_self;
</%init>
<%filter>
s/(\d+)/$1+1/ge;
</%filter>
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered_2',
                      description => 'make sure that results are only filtered once',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_filtered_2, x => 1 &>
<& support/cache_self_filtered_2, x => 99 &>
EOF
                      expect => <<'EOF',
x is 2

x is 2
EOF
                    );

#------------------------------------------------------------

# Note: expire_if works differently with CHI than with previous Mason caching.
# CHI does not actually expire the value (which would entail an extra write),
# it just returns false from get(). This was different in earlier verisons of CHI,
# so we don't test for $value3 as we do in the comprable 10-cache.t test.

    $group->add_test( name => 'expire_if',
                      description => 'test expire_if',
                      %chi_interp_params,
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef' ) %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia');
my $value1 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at <= $time-1 });
my $value2 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at >= $time });
</%init>
EOF
                      expect => <<'EOF',
gardenia, undef
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'busy_lock',
                      description => 'test busy_lock',
                      %chi_interp_params,
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'10 sec');
my $value2 = $cache->get('main');
</%init>
EOF
                      expect => <<'EOF',
undef, gardenia
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'busy_lock_expiration',
                      description => 'test busy_lock expiration',
                      %chi_interp_params,
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'1 sec');
sleep(1);
my $value2 = $cache->get('main');
</%init>
EOF
                      expect => <<'EOF',
undef, undef
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_die',
                          component => <<'EOF',
die
<%init>
return if $m->cache_self;
die 'foo';
</%init>
EOF
                        );

    $group->add_test( name => 'cache_self_death',
                      description => 'test $m->cache_self and death',
                      %chi_interp_params,
                      component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );
</%init>
EOF
                      expect_error => qr/foo at/,
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_abort2',
                          component => <<'EOF',
going to abort, a = <% $ARGS{a} %>
% $m->abort();
EOF
                        );

    $group->add_support( path => 'support/cache_self_abort',
                         component => <<'EOF',
<%init>
return if $m->cache_self;
$m->comp( 'cache_self_abort2', a=>5 );
</%init>
EOF
                       );

    $group->add_test( name => 'cache_self_abort',
                      description => 'test $m->cache_self and abort',
                      %chi_interp_params,
                      component => <<'EOF',
<%init>
eval { $m->comp( 'support/cache_self_abort', a=>5 ) };
eval { $m->comp( 'support/cache_self_abort', a=>10 ) };
</%init>
EOF
                      expect => <<'EOF'
going to abort, a = 5
going to abort, a = 5
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'support/cache_self_with_subexec2',
                         component => <<'EOF',
This is the subrequest, a = <% $ARGS{a} %>
EOF
                       );

    $group->add_support( path => 'support/cache_self_with_subexec',
                         component => <<'EOF',
% return if $m->cache_self;
% $m->subexec('cache_self_with_subexec2', a=>$ARGS{a});
EOF
                       );

    $group->add_test( name => 'cache_self_with_subexec',
                      description => 'test $m->subexec in presence of $m->cache_self',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_with_subexec, a=>5 &>
<& support/cache_self_with_subexec, a=>10 &>
EOF
                         expect => <<'EOF',
This is the subrequest, a = 5

This is the subrequest, a = 5
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'declined/dhandler',
                         component => <<'EOF',
decline was called
EOF
                       );

    $group->add_test( name => 'declined/cache_self_decline',
                      description => 'test $m->decline in presence of $m->cache_self',
                      %chi_interp_params,
                      component => <<'EOF',
% return if $m->cache_self;
% $m->decline;
EOF
                      expect => <<'EOF',
decline was called
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'data_cache_defaults',
                      description => 'modifying data_cache_defaults',
                      interp_params => { data_cache_api => 'chi', data_cache_defaults => { driver => 'Memory', global => 1 } },
                      component => <<'EOF',
Using driver '<% $m->cache->short_driver_name %>'

% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
                      expect => <<'EOF',
Using driver 'Memory'

Hello Dolly.
This was not cached.


Hello Dolly.
This was cached.


Hello Dolly.
This was cached.


EOF
                    );

#------------------------------------------------------------

    return $group;
}