#!/usr/bin/perl -w

use strict;

use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
use IO::File;

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

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'interp',
                                                      description => 'interp object functionality',
                                                      pre_test_cleanup => 0 );

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

    $group->add_support( path => '/autohandler_test/autohandler',
                         component => <<'EOF',
The recursive autohandler: <% $m->current_comp->path %>

% $m->call_next;
EOF
                       );


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

    $group->add_test( name => 'no recursive autohandlers',
                      description => 'tests turning off recursive autohandlers',
                      call_path => '/autohandler_test/subdir/hello',
                      component => <<'EOF',
Hello World!
EOF
                      expect => <<'EOF',
The recursive autohandler: /interp/autohandler_test/autohandler

Hello World!
EOF
                    );

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

    $group->add_test( name => 'no autohandlers',
                      description => 'tests turning off autohandlers by setting name to ""',
                      call_path => '/autohandler_test/subdir/hello',
                      interp_params => { autohandler_name => '' },
                      component => <<'EOF',
Hello World!
EOF
                      expect => <<'EOF',
Hello World!
EOF
                    );


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

    $group->add_support( path => '/autohandler_test/subdir/plainfile',
                         component => <<'EOF',
The local autohandler: <% $m->current_comp->path %>

% $m->call_next;
EOF
                       );


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

    $group->add_test( name => 'alternate autohandler name',
                      description => 'tests that providing an alternate name for autohandlers works',
                      call_path => '/autohandler_test/subdir/hello',
                      interp_params => { autohandler_name => 'plainfile' },
                      component => <<'EOF',
Hello World!
EOF
                      expect => <<'EOF',
The local autohandler: /interp/autohandler_test/subdir/plainfile

Hello World!
EOF
                    );

    my $alt_root = File::Spec->catdir( HTML::Mason::Tests->tests_class->base_path, 'alt_root' );
    my @roots = ( [ main => HTML::Mason::Tests->tests_class->comp_root],
                  [ alt => $alt_root ] );


    #HACK!
    HTML::Mason::Tests->tests_class->write_comp( '/alt_root/interp/comp_root_test/private2',
                                                 File::Spec->catdir( $alt_root, 'interp', 'comp_root_test' ),
                                                 'private2',
                                                 <<'EOF' );
private2 in the alternate component root.
<& showcomp &>
EOF

    HTML::Mason::Tests->tests_class->write_comp( '/alt_root/interp/comp_root_test/shared',
                                                 File::Spec->catdir( $alt_root, 'interp', 'comp_root_test' ),
                                                 'shared',
                                                 <<'EOF' );
shared.html in the alternate component root.
<& showcomp &>
EOF


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

    $group->add_support( path => '/comp_root_test/showcomp',
                         component => <<'EOF',
% my $comp = $m->callers(1);
<& /shared/display_comp_obj, comp=>$comp &>
EOF
                       );


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

    $group->add_test( name => 'shared',
                      description => 'test that component in both comp_roots is called in first comp_root',
                      call_path => '/comp_root_test/shared',
                      interp_params => { comp_root => \@roots },
                      component => <<'EOF',
shared in the main component root.
<& showcomp &>
EOF
                      expect => <<'EOF',
shared in the main component root.
Declared args:

I am not a subcomponent.
I am not a method.
I am file-based.
My short name is shared.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/shared [main].

My path is /interp/comp_root_test/shared.
My comp_id is /main/interp/comp_root_test/shared.



EOF
                    );


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

    $group->add_test( name => 'private1',
                      description => 'test that component in first comp_root is found',
                      call_path => '/comp_root_test/private1',
                      interp_params => { comp_root => \@roots },
                      component => <<'EOF',
private1 in the main component root.
<& showcomp &>
EOF
                      expect => <<'EOF',
private1 in the main component root.
Declared args:

I am not a subcomponent.
I am not a method.
I am file-based.
My short name is private1.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/private1 [main].

My path is /interp/comp_root_test/private1.
My comp_id is /main/interp/comp_root_test/private1.



EOF
                    );


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

    $group->add_test( name => 'private2',
                      description => 'test that component in second comp_root is found',
                      call_path => '/comp_root_test/private2',
                      path => '/foo', # its already written.  HACK!
                      interp_params => { comp_root => \@roots },
                      component => <<'EOF',
foo
EOF
                      expect => <<'EOF',
private2 in the alternate component root.
Declared args:

I am not a subcomponent.
I am not a method.
I am file-based.
My short name is private2.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/private2 [alt].

My path is /interp/comp_root_test/private2.
My comp_id is /alt/interp/comp_root_test/private2.



EOF
                    );

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

    $group->add_support( path => 'support/recurse_test',
                         component => <<'EOF',
Entering <% $count %><p>
% if ($count < $max) {
<& recurse_test, count=>$count+1, max=>$max &>
% }
Exiting <% $count %><p>\
<%args>
$count=>0
$max
</%args>
EOF
                       );


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

    $group->add_test( name => 'max_recurse_1',
                      description => 'Test that recursion 8 levels deep is allowed',
                      component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>8) };
EOF
                      expect => <<'EOF',
Entering 0<p>
Entering 1<p>
Entering 2<p>
Entering 3<p>
Entering 4<p>
Entering 5<p>
Entering 6<p>
Entering 7<p>
Entering 8<p>
Exiting 8<p>
Exiting 7<p>
Exiting 6<p>
Exiting 5<p>
Exiting 4<p>
Exiting 3<p>
Exiting 2<p>
Exiting 1<p>
Exiting 0<p>
EOF
                    );


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

    $group->add_test( name => 'max_recurse_2',
                      description => 'Test that recursion is stopped after 32 levels',
                      interp_params => { autoflush => 1 },
                      component => '<& support/recurse_test, max=>48 &>',
                      expect_error => qr{32 levels deep in component stack \(infinite recursive call\?\)},
                    );


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

    $group->add_test( name => 'max_recurse_3',
                      description => 'Test interp max_recurse param',
                      interp_params => { max_recurse => 50 },
                      component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>48) };

<% $@ ? "Error" : "No error" %>
EOF
                      expect => <<'EOF',
Entering 0<p>
Entering 1<p>
Entering 2<p>
Entering 3<p>
Entering 4<p>
Entering 5<p>
Entering 6<p>
Entering 7<p>
Entering 8<p>
Entering 9<p>
Entering 10<p>
Entering 11<p>
Entering 12<p>
Entering 13<p>
Entering 14<p>
Entering 15<p>
Entering 16<p>
Entering 17<p>
Entering 18<p>
Entering 19<p>
Entering 20<p>
Entering 21<p>
Entering 22<p>
Entering 23<p>
Entering 24<p>
Entering 25<p>
Entering 26<p>
Entering 27<p>
Entering 28<p>
Entering 29<p>
Entering 30<p>
Entering 31<p>
Entering 32<p>
Entering 33<p>
Entering 34<p>
Entering 35<p>
Entering 36<p>
Entering 37<p>
Entering 38<p>
Entering 39<p>
Entering 40<p>
Entering 41<p>
Entering 42<p>
Entering 43<p>
Entering 44<p>
Entering 45<p>
Entering 46<p>
Entering 47<p>
Entering 48<p>
Exiting 48<p>
Exiting 47<p>
Exiting 46<p>
Exiting 45<p>
Exiting 44<p>
Exiting 43<p>
Exiting 42<p>
Exiting 41<p>
Exiting 40<p>
Exiting 39<p>
Exiting 38<p>
Exiting 37<p>
Exiting 36<p>
Exiting 35<p>
Exiting 34<p>
Exiting 33<p>
Exiting 32<p>
Exiting 31<p>
Exiting 30<p>
Exiting 29<p>
Exiting 28<p>
Exiting 27<p>
Exiting 26<p>
Exiting 25<p>
Exiting 24<p>
Exiting 23<p>
Exiting 22<p>
Exiting 21<p>
Exiting 20<p>
Exiting 19<p>
Exiting 18<p>
Exiting 17<p>
Exiting 16<p>
Exiting 15<p>
Exiting 14<p>
Exiting 13<p>
Exiting 12<p>
Exiting 11<p>
Exiting 10<p>
Exiting 9<p>
Exiting 8<p>
Exiting 7<p>
Exiting 6<p>
Exiting 5<p>
Exiting 4<p>
Exiting 3<p>
Exiting 2<p>
Exiting 1<p>
Exiting 0<p>
No error
EOF
                    );


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

    $group->add_support( path => '/support/code_cache/show_code_cache',
                         component => <<'EOF',
% $m->interp->purge_code_cache();
% my $code_cache = $m->interp->{code_cache};
% my @plain_comp_names = sort grep { /^plain/ } map { $_->{comp}->name } values(%$code_cache);
Code cache contains: <% join(", ", @plain_comp_names) %>
EOF
                       );


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

    foreach my $i (1..7) {
        $group->add_support( path => "/support/code_cache/plain$i",
                             component => "",
                           );
    }

    $group->add_support( path => "/support/code_cache/call_plain_comps",
                         component => <<'EOF',
<& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &>
<& plain2 &><& plain2 &><& plain2 &><& plain2 &><& plain2 &>
<& plain3 &><& plain3 &><& plain3 &>
<& plain4 &>
<& plain5 &><& plain5 &>
<& plain6 &><& plain6 &><& plain6 &><& plain6 &>
<& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &>
EOF
                       );

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

    my $create_code_cache_test = sub {
        my ($max_size, $expected) = @_;
        $group->add_test( name => "code_cache_$max_size",
                          interp_params => { code_cache_max_size => $max_size },
                          description => "code cache: max_size = $max_size",
                          component => <<'EOF',
<%init>
$m->scomp('support/code_cache/call_plain_comps');
$m->scomp('support/code_cache/call_plain_comps');
$m->comp('support/code_cache/show_code_cache');
</%init>
EOF
                          expect => <<"EOF",
Code cache contains: $expected
EOF
                          );
    };

    $create_code_cache_test->('unlimited', 'plain1, plain2, plain3, plain4, plain5, plain6, plain7');
    $create_code_cache_test->(0, '');
    $create_code_cache_test->(4, 'plain1, plain2, plain7');
    $create_code_cache_test->(8, 'plain1, plain2, plain3, plain5, plain6, plain7');

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

    $group->add_test( name => 'dhandler_name',
                      description => 'Test that providing an alternate name for dhandlers works',
                      path => 'dhandler_test/plainfile',
                      call_path => 'dhandler_test/foo/blag',
                      interp_params => { dhandler_name => 'plainfile' },
                      component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
EOF
                      expect => <<'EOF',
dhandler arg = foo/blag
EOF
                    );


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

    $group->add_test( name => 'dhandler_name2',
                      description => 'Shut off dhandlers',
                      path => 'dhandler_test/plainfile',
                      call_path => 'dhandler_test/foo/blag',
                      interp_params => { dhandler_name => '' },
                      component => 'foo',
                      expect_error => qr{could not find component},
                    );


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

    $group->add_test( name => 'dhandler_name0',
                      description => 'dhandler_name => 0 should not shut off dhandlers',
                      path => 'dhandler_test/0',
                      call_path => 'dhandler_test/foo/blag',
                      interp_params => { dhandler_name => '0' },
                      component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
comp = <% $m->current_comp->name %>
EOF
                      expect => <<'EOF',
dhandler arg = foo/blag
comp = 0
EOF
                    );


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

    $group->add_support( path => 'mode_test',
                         component => <<'EOF',
First of all I'd
% $m->clear_buffer;
No what I really wanted to say was
% $m->clear_buffer;
Oh never mind.
EOF
                       );


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

    $group->add_test( name => 'no_autoflush_mode',
                      description => 'Test that no autoflush (batch) mode setting works',
                      component => <<'EOF',
<& mode_test &>
EOF
                      expect => <<'EOF',
Oh never mind.
EOF
                    );


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

    $group->add_test( name => 'autoflush_mode',
                      description => 'Test that autoflush setting works',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
<& mode_test &>
EOF
                      expect => <<'EOF',
First of all I'd
No what I really wanted to say was
Oh never mind.
EOF
                    );


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

    $group->add_support( path => 'preloads_test/show_code_cache',
                         component => <<'EOF',
Code cache contains:
% my %c = %{$m->interp->{code_cache}};
<% join("\n",sort(keys(%c))) %>
EOF
                    );



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

    $group->add_support( path => 'preloads_test/hello',
                         component => 'hello',
                       );


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

    $group->add_support( path => 'preloads_test/goodbye',
                         component => 'goodbye',
                       );


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

    $group->add_support( path => 'preloads_test/howareyou',
                         component => 'howareyou',
                       );


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

    $group->add_support( path => 'preloads_test/subdir/in_a_subdir',
                         component => 'howareyou',
                       );

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

    $group->add_test( name => 'preload_1',
                      description => 'Make sure no preloading is done by default',
                      component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
                      expect => <<'EOF',
Code cache contains:
/interp/preload_1
/interp/preloads_test/show_code_cache
EOF
                    );


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

    $group->add_test( name => 'preload_2',
                      description => 'Preload a single component by filename',
                      interp_params => { preloads => [ '/interp/preloads_test/hello' ] },
                      component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
                      expect => <<'EOF',
Code cache contains:
/interp/preload_2
/interp/preloads_test/hello
/interp/preloads_test/show_code_cache
EOF
                    );


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

    $group->add_test( name => 'preload_3',
                      description => 'Preload all components (including subdirectory) by glob pattern',
                      interp_params => { preloads => [ '/interp/preloads_test/*', '/interp/preloads_test/*/*' ] },
                      component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
                      expect => <<'EOF',
Code cache contains:
/interp/preload_3
/interp/preloads_test/goodbye
/interp/preloads_test/hello
/interp/preloads_test/howareyou
/interp/preloads_test/show_code_cache
/interp/preloads_test/subdir/in_a_subdir
EOF
                    );

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

    my $interp = HTML::Mason::Tests->tests_class->_make_interp
        ( data_dir => $group->data_dir,
          comp_root => $group->comp_root,
          );
    $interp->compiler->allow_globals( qw($global) );
    $interp->set_global( global => 'parsimmon' );


    $group->add_test( name => 'globals',
                      description => 'Test setting a global in interp & compiler objects',
                      interp => $interp,
                      component => <<'EOF',
<% $global %>
EOF
                      expect => <<'EOF',
parsimmon
EOF
                    );

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

    $group->add_support( path => '/comp_path_test/a/b/c/foo',
                         component => <<'EOF',
I am foo!
EOF
                       );

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

    $group->add_test( name => 'process_comp_path',
                      description => 'Test that component paths cannot be resolved outside the comp root',
                      component => <<'EOF',
<& ../../../../../interp/comp_path_test/a/b/c/../c/foo &>
EOF
                      expect => <<'EOF'
I am foo!

EOF
                    );

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

    $group->add_test( name => 'process_comp_path2',
                      description => 'Test that component paths containing /../ work as long they stay in the comp root',
                      path => '/comp_path_test/a/b/d/process',
                      call_path => '/comp_path_test/a/b/d/process',
                      component => <<'EOF',
<& ../c/foo &>
EOF
                      expect => <<'EOF'
I am foo!

EOF
                    );

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

    $group->add_test( name => 'default_warnings',
                      description => 'test that warnings during component compilation cause an exception except for redefined subs',
                      component => <<'EOF',
a global: <% $GLOBAL %>
<%once>
sub foo { 1 }
sub foo { 1 }
</%once>
EOF
                      expect_error => qr/Global symbol "\$GLOBAL" requires explicit package name/,
                    );

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

    $group->add_test( name => 'ignore_warnings',
                      description => 'test that setting ignore_warnings_exp works',
                      interp_params => { ignore_warnings_expr => qr/useless use of "re" pragma/i },
                      component => <<'EOF',
% use re;
foo
EOF
                      expect => <<'EOF',
foo
EOF
                    );

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

    $group->add_test( name => 'ignore_all_warnings',
                      description => 'test ignoring all warnings',
                      interp_params =>
                      { ignore_warnings_expr => '.' },
                      component => <<'EOF',
<%once>
sub foo { 1 }
sub foo { 1 }
</%once>
foo
EOF
                      expect => <<'EOF',
foo
EOF
                    );


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

    $group->add_test( name => 'make_anonymous_component',
                      description => 'test make_component() without a path',
                      component => <<'EOF',
<%init>
my $ctext = q|
% my $x = 'Hello, ';
<% $x %>|;
my $comp = $m->interp->make_component( comp_source => $ctext );
</%init>
% $m->comp($comp);
World
EOF
                      expect => <<'EOF',

Hello, World
EOF
                    );

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

    $group->add_test( name => 'read_write_contained',
                      description => 'test that we can read/write contained object params',
                      component => <<'EOF',
% $m->autoflush(1);
% my $req = $m->make_subrequest(comp=>($m->interp->make_component(comp_source => 'hi')));
% $m->autoflush(0);
autoflush for new request is <% $req->autoflush %>
EOF
                      expect => <<'EOF',
autoflush for new request is 1
EOF
                    );

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

    if ( load_pkg('Cache::Cache') && load_pkg('Cache::MemoryCache') )
    {
        $group->add_test( name => 'no_data_dir',
                          description => 'test interp without a data directory',
                          interp => HTML::Mason::Tests->tests_class->_make_interp( comp_root => HTML::Mason::Tests->tests_class->comp_root ),
                          component => <<'EOF',
Hello World!
<% ref $m->cache %>
EOF
                          expect => <<'EOF',
Hello World!
HTML::Mason::Cache::MemoryCache
EOF
                          );
    }

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

    $group->add_support( path => 'no_comp_root_helper',
                         component => <<'EOF',
I am rootless
EOF
                       );

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

    $group->add_test( name => 'no_comp_root',
                      description => 'test interp without a comp root or data dir',
                      component => <<'EOF',
% my $buffer;
% my $interp = HTML::Mason::Tests->tests_class->_make_interp( out_method => \$buffer );
% $interp->exec( "/mason_tests/$$/comps/interp/no_comp_root_helper" );
<% $buffer %>
EOF
                      expect => <<'EOF',
I am rootless
EOF
                    );

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

    $group->add_test( name => 'make_component_error',
                      description => 'make sure a proper exception is thrown with make_component syntax errors',
                      component => <<'EOF',
% $m->interp->make_component(comp_source => '<% &>');
EOF
                      # Would be better to do $@->isa(syntax-error) or the like.
                      expect_error => qr/without matching/,
                    );

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

    if ( $] < 5.012 && load_pkg('Switch') )
    {
        $group->add_test( name => 'source_filter',
                          description => 'make sure source filters work',
                          interp_params =>
                          { ignore_warnings_expr =>
                            qr/uninitialized|Subroutine .* redefined/i },
                          component => <<'EOF',
no explosion
<%init>
use Switch;

my $x = 1;

switch ($x) { case 1 { $x = 2 } }
</%init>
EOF
                          expect => <<'EOF',
no explosion
EOF
                        );
    }

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

    $group->add_test( name => 'escape_flags',
                      description => 'test setting escape flags via constructor',
                      interp_params =>
                      { escape_flags => { uc => sub { ${$_[0]} = uc ${$_[0]} } } },
                      component => <<'EOF',
<% 'upper case' | uc %>
EOF
                      expect => <<'EOF',
UPPER CASE
EOF
                    );


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

    # Note that setting out_method on the interp affects _future_
    # request objects, not the current one.  This is just a test to
    # make sure we can set it at all.
    $group->add_test( name => 'set_out_method',
                      description => 'test setting out_method on the interp object',
                      component => <<'EOF',
foo
% $m->interp->out_method( sub {} );
bar
baz
EOF
                      expect => <<'EOF',
foo
bar
baz
EOF
                    );


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

    $group->add_support( path => '/support/corrupt_object_file',
                         component => "I was loaded\n",
                        );

    $group->add_test( name => 'corrupt_object_file',
                      description => 'test that Mason can recover from a corrupt or empty object file',
                      component => <<'EOF',
<%init>
my $path = 'support/corrupt_object_file';    
my $comp = $m->fetch_comp('support/corrupt_object_file');
$m->comp($comp);
my $object_file = $comp->object_file;
die "object file does not exist" unless -f $object_file;
die "object file is not writable" unless -w $object_file;

my $corrupt_object_file_and_reload = sub {
    my ($content) = @_;
    my $original_object_file_size = (stat($object_file))[7];

    my $fh = new IO::File ">$object_file"
        or die "cannot write $object_file: $!";
    $fh->print($content);
    $fh->close();
    die "object file is not the right size after corruption"
        unless (stat($object_file))[7] == length($content);

    $m->interp->flush_code_cache();
    $m->comp($path);
    die "object file is the same size after reloading"
        if (stat($object_file))[7] == length($content);
};

$corrupt_object_file_and_reload->("");
$corrupt_object_file_and_reload->(0);
$corrupt_object_file_and_reload->("return 5");
$corrupt_object_file_and_reload->("slkd%^^&*(@@");
$corrupt_object_file_and_reload->("die 'bleah';");
</%init>
EOF
                      expect => <<'EOF',
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
EOF
                    );

    return $group;
}