The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

use strict;
use warnings;

my $Config_File            = 't/testconf.conf';
my $Containing_Config_File = 't/testconf-container.conf';



use Test::More 'no_plan';

{
    package WebApp::Foo::Bar::Baz;
    use Test::More;

    use base 'CGI::Application';
    use CGI::Application::Plugin::Config::General;

    sub setup {
        my $self = shift;

        $self->header_type('none');
        $self->run_modes(
            'start' => 'default',
        );
        $self->mode_param(
            '-path_info' => 2,
        );

        write_original_config();

        # Simple read with caching
        $self->conf('01')->init(
            -ConfigFile       => $Config_File,
        );
        $self->conf('02')->init(
            -ConfigFile       => $Config_File,
        );

        ok($self->conf('01')->obj eq $self->conf('02')->obj, 'Caching ON: objects identical');
        my $config = $self->conf('01')->getall;
        is($config->{'original'}, 1,        '01.original');
        is($config->{'modified'}, 0,        '01.modified');
        is($config->{'fruit'},    'banana', '01.fruit');
        is($config->{'truck'},    'red',    '01.truck');


        # Simple read with caching disabled
        $self->conf('03')->init(
            -ConfigFile       => $Config_File,
            -CacheConfigFiles => 0,
        );
        $self->conf('04')->init(
            -ConfigFile       => $Config_File,
            -CacheConfigFiles => 0,
        );

        ok($self->conf('03')->obj ne $self->conf('04')->obj, 'Caching OFF: objects differ');

        # Delete file in between first and second read (caching ON)
        $self->conf('05')->init(
            -ConfigFile       => $Config_File,
        );

        delete_config();

        eval {
            $self->conf('06')->init(
                -ConfigFile       => $Config_File,
            );
        };
        ok(!$@, 'Delete, Caching ON, no error');
        ok($self->conf('05')->obj eq $self->conf('06')->obj, 'Delete, Caching ON:  objects identical');

        # Delete file in between first and second read (caching OFF)
        write_original_config();
        $self->conf('07')->init(
            -ConfigFile       => $Config_File,
            -CacheConfigFiles => 0,
        );

        delete_config();

        eval {
            $self->conf('08')->init(
                -ConfigFile       => $Config_File,
                -CacheConfigFiles => 0,
            );
        };
        ok($@, 'Delete, Caching OFF, error thrown');



        # Modify before statconfig runs out
        $self->conf('09')->init(
            -ConfigFile       => $Config_File,
        );

        write_modified_config();
        $self->conf('10')->init(
            -ConfigFile       => $Config_File,
        );

        ok($self->conf('09')->obj eq $self->conf('10')->obj, 'Modify before statconfig: Caching ON: objects identical');
        $config = $self->conf('09')->getall;
        is($config->{'original'}, 1,        '09.original');
        is($config->{'modified'}, 0,        '09.modified');
        is($config->{'fruit'},    'banana', '09.fruit');
        is($config->{'truck'},    'red',    '09.truck');


        # Modify before statconfig runs out (short statconfig)
        write_original_config();
        $self->conf('11')->init(
            -ConfigFile       => $Config_File,
            -StatConfig       => 2,
        );

        write_modified_config();
        $self->conf('12')->init(
            -ConfigFile       => $Config_File,
            -StatConfig       => 2,
        );

        ok($self->conf('11')->obj eq $self->conf('12')->obj, 'Modify before (short) statconfig: Caching ON: objects identical');
        $config = $self->conf('11')->getall;
        is($config->{'original'}, 1,        '11.original');
        is($config->{'modified'}, 0,        '11.modified');
        is($config->{'fruit'},    'banana', '11.fruit');
        is($config->{'truck'},    'red',    '11.truck');

        # Modify after statconfig runs out
        write_original_config();
        $self->conf('13')->init(
            -ConfigFile       => $Config_File,
            -StatConfig       => 2,
        );

        sleep 3;
        write_modified_config();

        $self->conf('14')->init(
            -ConfigFile       => $Config_File,
            -StatConfig       => 2,
        );

        ok($self->conf('13')->obj ne $self->conf('14')->obj, 'Modify after statconfig: Caching ON: objects differ');
        $config = $self->conf('13')->getall;
        is($config->{'original'}, 1,        '13.original');
        is($config->{'modified'}, 0,        '13.modified');
        is($config->{'fruit'},    'banana', '13.fruit');
        is($config->{'truck'},    'red',    '13.truck');

        $config = $self->conf('14')->getall;
        is($config->{'original'}, 0,        '14.original');
        is($config->{'modified'}, 1,        '14.modified');
        is($config->{'fruit'},    'plum',   '14.fruit');
        is($config->{'truck'},    'red',    '14.truck');

        sleep 3;

        # Modify after statconfig runs out (modified config is same size)
        write_original_config();
        $self->conf('15')->init(
            -ConfigFile       => $Config_File,
            -StatConfig       => 2,
        );

        sleep 3;
        write_modified_same_size_config();

        $self->conf('16')->init(
            -ConfigFile       => $Config_File,
            -StatConfig       => 2,
        );

        ok($self->conf('15')->obj ne $self->conf('16')->obj, 'Modify after statconfig: Caching ON, modified config same size: objects differ');
        $config = $self->conf('15')->getall;
        is($config->{'original'}, 1,        '15.original');
        is($config->{'modified'}, 0,        '15.modified');
        is($config->{'fruit'},    'banana', '15.fruit');
        is($config->{'truck'},    'red',    '15.truck');

        $config = $self->conf('16')->getall;
        is($config->{'original'}, 0,        '16.original');
        is($config->{'modified'}, 1,        '16.modified');
        is($config->{'fruit'},    'banana', '16.fruit');
        is($config->{'truck'},    'RED',    '16.truck');


        SKIP: {
            skip "Installed Config::General doesn't support 'files'", 11 unless $self->conf('01')->obj->can('files');
            write_original_config();
            write_containing_config();
            $self->conf('50')->init(
                -ConfigFile       => $Containing_Config_File,
                -StatConfig       => 2,
            );

            write_modified_config();
            sleep 3;

            $self->conf('51')->init(
                -ConfigFile       => $Containing_Config_File,
                -StatConfig       => 2,
            );

            ok($self->conf('50')->obj ne $self->conf('51')->obj, 'Include files - Modify after statconfig: Caching ON: objects differ');
            $config = $self->conf('50')->getall;
            is($config->{'container'}, 1,        '50.container');
            is($config->{'original'},  1,        '50.original');
            is($config->{'modified'},  0,        '50.modified');
            is($config->{'fruit'},     'banana', '50.fruit');
            is($config->{'truck'},     'red',    '50.truck');

            $config = $self->conf('51')->getall;
            is($config->{'container'}, 1,        '51.container');
            is($config->{'original'},  0,        '51.original');
            is($config->{'modified'},  1,        '51.modified');
            is($config->{'fruit'},     'plum',   '51.fruit');
            is($config->{'truck'},     'red',    '51.truck');


            delete_containing_config();

        }


        delete_config();




    }

    sub default {
        my $self = shift;
        return "";
    }

    sub write_original_config {
        my $filename = $Config_File;
        my $config = q{
            original = 1
            modified = 0
            fruit    = banana
            truck    = red
        };

        write_config($filename, $config);
    }
    sub write_containing_config {
        my $filename = $Containing_Config_File;
        my $config = qq{
            <<include $Config_File>>
            container = 1
        };

        write_config($filename, $config);
    }

    sub write_modified_config {
        my $filename = $Config_File;
        my $config = q{
            original = 0
            modified = 1
            fruit    = plum
            truck    = red
        };
        write_config($filename, $config);
    }

    sub write_modified_same_size_config {
        my $filename = $Config_File;
        my $config = q{
            original = 0
            modified = 1
            fruit    = banana
            truck    = RED
        };
        write_config($filename, $config);
    }

    sub delete_config {
        unlink $Config_File;
    }
    sub delete_containing_config {
        unlink $Containing_Config_File;
    }

    sub write_config {
        my $filename = shift;
        my $config   = shift;
        open my $fh, '>', $filename or die "Can't clobber temporary config file $filename: $!\n";
        print $fh $config;
        close $fh;
    }


}

my $webapp = WebApp::Foo::Bar::Baz->new;
$webapp->run;