The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl  -T
use Test::More;
use Test::Taint;
use Test::Regression;
use English qw(-no_match_vars);

if ($OSNAME eq 'MSWin32') {
    my $msg = 'Not running these tests on windows yet';
    plan skip_all => $msg;
    exit(0);
}
plan tests => 7;

use strict;
use warnings;

use CGI ();
taint_checking_ok('taint checking is on');
$ENV{CGI_APP_RETURN_ONLY} = 1;

my $cap_options =
{
        DRIVER => [ 'Generic', { user1 => '123' } ],
        STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'],
        POST_LOGIN_CALLBACK => \&TestAppAuthenticate::post_login,
};

{

    package TestAppAuthenticate;

    use base qw(CGI::Application);
    use CGI::Application::Plugin::Authentication;

    sub setup {
        my $self = shift;
        $self->start_mode('one');
        $self->run_modes([qw(one two)]);
        $self->authen->protected_runmodes(qw(two));
        $self->authen->config($cap_options);
    }

    sub one {
        my $self = shift;
    }

    sub two {
        my $self = shift;
    }

    sub post_login {
      my $self = shift;

      my $count=$self->param('post_login')||0;
      $self->param('post_login' => $count + 1 );
    }

}

test_auth();
test_auth('cosmetic', {
        TITLE=>'Aanmelden',
        USERNAME_LABEL=>'Gebruikersnaam',
        PASSWORD_LABEL=>'Wachtwoord',
        SUBMIT_LABEL=>'Aanmelden',
        COMMENT=>'Vul uw gebruikersnaam en wachtwoord in de velden hieronder.',
        REMEMBERUSER_LABEL=>'Onthouden Gebruikersnaam',
        INVALIDPASSWORD_MESSAGE=>'Ongeldige gebruikersnaam of wachtwoord <br /> (login poging% d)',
        INCLUDE_STYLESHEET=>0
});
test_auth('red', {
        BASE_COLOUR=>'#884454',
        LIGHT_COLOUR=>'49%',
        LIGHTER_COLOUR=>'74%',
        DARK_COLOUR=>'29%',
        DARKER_COLOUR=>'59%'
}, 1);
test_auth('green', {
        BASE_COLOUR=>'#2cf816'
}, 1);
test_auth('grey_extra', {
        BASE_COLOUR=>'#445588',
}, 1);
test_auth('grey_extra2', {
        GREY_COLOUR=>'#334488',
        BASE_COLOUR=>'#445588',
}, 1);



sub test_auth {
    my $test_name = shift || "default";
    my $login_form = shift;
    my $color_calc_required = shift;
    if (defined $color_calc_required) {
        eval "use Color::Calc";
        if ($@) {
                diag "Color::Calc required for this sub test";
                pass($test_name);
                return;
        }
    }
    subtest $test_name => sub {
       plan tests => 11;
       local $cap_options->{LOGIN_FORM} = $login_form if $login_form;

       # Missing Credentials
       my $param = { authen_username => 'user1', rm => 'two' };
       taint_deeply($param);
       my $query = CGI->new( $param);

       my $cgiapp = TestAppAuthenticate->new( QUERY => $query );

       my $results = $cgiapp->run;

       ok(!$cgiapp->authen->is_authenticated,"$test_name - login failure");
       is( $cgiapp->authen->username, undef, "$test_name - username not set" );
       is( $cgiapp->param('post_login'),1,"$test_name - POST_LOGIN_CALLBACK executed" );
       is( $cgiapp->authen->_detaint_destination, '', "$test_name - _detaint_destination");
       untainted_ok($cgiapp->authen->_detaint_destination, "$test_name - _detaint_destination untainted");
       # hash order is random
       ok($cgiapp->authen->_detaint_selfurl eq 'http://localhost?authen_username=user1;rm=two' ||
          $cgiapp->authen->_detaint_selfurl eq 'http://localhost?rm=two;authen_username=user1',
          "$test_name - _detaint_selfurl");
       untainted_ok($cgiapp->authen->_detaint_selfurl, "$test_name - _detaint_selfurl untainted");
       is( $cgiapp->authen->_detaint_url, '', "$test_name - _detaint_url");
       untainted_ok($cgiapp->authen->_detaint_url, "$test_name - _detaint_url untainted");
       TODO: {
          local $TODO = 'Checking output against past runs is incompatible with
          random hash order.  URLs with params are generated from the keys of a
          hash and thus each run can have some minor differences in URLs.';
          ok_regression(sub {$cgiapp->authen->login_box}, "t/out/$test_name", "$test_name - verify login box");
       }
       untainted_ok($cgiapp->authen->login_box, "$test_name - check login box taint");
    }
}