view release on metacpan or  search on metacpan

t/05-relogin.t  view on Meta::CPAN

$app   = MyTestApp_custom_login_profile->new(QUERY => $query);
$app->run;

ok($app->stash->{'Seen_Run_Mode'}{'page_the_second'},  '[relogin sub to page_the_second, pass, custom profile] fall through to page_the_second');
is($app->stash->{'Final_Run_Mode'}, 'page_the_second', '[relogin sub to page_the_second, pass, custom profile] final page was page_the_second');


#######################################################################
# fail consistency check again
# TODO: the system should allow a second relogin without hosing the user's session.
# (e.g. the user might hit the back button and retype their password)

$Consistency_Match = qr/hobgoblin/;
$query = new CGI;
$query->param($_, $link_param{$_}) for keys %link_param;


$app   = MyTestApp->new(QUERY => $query);
$app->stash->{'Suppress_Output'} = 1;
$app->run;

ok($app->stash->{'Seen_Run_Mode'}{'relogin'},  '[page_the_second, fail _relogin_test] redirected to relogin');
is($app->stash->{'Final_Run_Mode'}, 'relogin', '[page_the_second, fail _relogin_test] final page was relogin');

undef $app->stash->{'Suppress_Output'};

$Consistency_Match = qr/goblin/;


#######################################################################
# relogin submitted, successfully reauthenticated

$query = new CGI;
$query->param('_session_id',  $session_id);
$query->param('come_from_rm', 'relogin');
$query->param('rm',           'relogin');
$query->param('password',     'seekrit');

$app   = MyTestApp->new(QUERY => $query);
$app->run;

ok($app->stash->{'Seen_Run_Mode'}{'page_the_second'},  '[relogin sub to page_the_second, pass] fall through to page_the_second');
is($app->stash->{'Final_Run_Mode'}, 'page_the_second', '[relogin sub to page_the_second, pass] final page was page_the_second');



#######################################################################
# Verify the integrity of a form posting through the relogin

$Consistency_Match = qr/hobgoblin/;

# Create a CGI query in a data file

# my $input = CGI::Test::Input::Multipart->new();
#
# $input->add_field("come_from_rm", "page_the_second");
# $input->add_field("rm",           "page_the_second");
# # $input->add_field("bork",         "bork\n\rfoo".chr(27)."beeble\n");
# $input->add_field("_session_id",  $session_id);
# $input->add_file("upfile",        "t/data/test_upload.txt");

# Ideas and code borrowed from Gabor Szabo's CGI::Upload test script
# and from CGI::Test::Input::Multipart by Raphael Manfredi and Steven Hilton

my $unusual_value = "bork\n\rfoo".chr(27)."beeble\r\n\r\nkowabunga";
my %form_params = (
    come_from_rm => 'page_the_second',
    rm           => 'page_the_second',
    _session_id  => $session_id,
    'unusual'    => $unusual_value,
);

my $boundary = "----------1234567890";

my $data = '';

foreach my $param (keys %form_params) {
    $data .= qq(--$boundary\r\n);
    $data .= qq(Content-Disposition: form-data; name="$param"\r\n);
    $data .= qq(\r\n);
    $data .= qq($form_params{$param});
    $data .= qq(\r\n);
}

my %files = (
    first_files => [qw(
        t/data/jabberwocky.txt
        t/data/walrus.txt
    )],
    second_files => [qw(
        t/data/snark.txt
    )],
);

my %file_contents;
foreach my $field_name (keys %files) {
    foreach my $fn (@{ $files{$field_name} }) {
        $data .= qq(--$boundary\r\n);
        $data .= qq(Content-Disposition: form-data; name="$field_name"; filename="$fn"\r\n);
        $data .= qq(Content-Type: text/plain\r\n);
        $data .= qq(\r\n);

        local $/;
        open my $fh, '<', $fn or die "can't open $fn";

        $file_contents{$fn} = <$fh>;

        $data .= qq($file_contents{$fn}\r\n);
    }
}

$data .= qq(--$boundary--\r\n);


open my $fh, '+>', 't/data/formdata' or die "Can't clobber t/data/formdata: $!\n";

print $fh "Content-Type: multipart/form-data; boundary=$boundary\015\012";
print $fh "Content-Length: ", length($data), "\015\012";
print $fh "\015\012";
print $fh $data;
seek $fh, 0, 0;

# Dup STDIN
open my $old_stdin, '>&', 'STDIN' or die "Can't dup STDIN: $!\n";
open STDIN, '>&', $fh or die "Can't redirect STDIN: $!\n" ;

$ENV{'REQUEST_METHOD'} = 'POST';
$ENV{'CONTENT_TYPE'}   = "multipart/form-data; boundary=$boundary";
$ENV{'CONTENT_LENGTH'} = -s 't/data/formdata';

$query = CGI->new;

ok(!$query->cgi_error, 'CGI object successfully created') or warn "CGI error: ". $query->cgi_error . "\n";

# restore STDIN
open STDIN, '>&', $old_stdin, or die "Can't restore STDIN: $!\n";

$app   = MyTestApp->new(QUERY => $query);
$app->stash->{'Suppress_Output'} = 1;
$app->run;
undef $app->stash->{'Suppress_Output'};

ok($app->stash->{'Seen_Run_Mode'}{'relogin'},  '[page_the_second, query test, fail _relogin_test] redirected to relogin');
is($app->stash->{'Final_Run_Mode'}, 'relogin', '[page_the_second, query test, fail _relogin_test] final page was relogin');

my %upload_contents;
{
    local $/;

    for my $field (qw(first_files second_files)) {
        my (@fh)        = $query->upload($field);
        my (@filenames) = $query->param($field);

        for (my $i = 0; $i < @fh; $i++) {
            my $handle = $fh[$i];
            $upload_contents{$filenames[$i]} = <$handle>;
        }
    }
}

for my $file (keys %file_contents) {
    is($upload_contents{$file}, $file_contents{$file}, "[initial query] upload file contents okay: $file");
}
is($query->param('unusual'), $unusual_value,           '[initial query] unusual value survived');


$Consistency_Match = qr/goblin/;

#######################################################################
# relogin submitted, successfully reauthenticated

$query = new CGI;
$query->param('_session_id',  $session_id);
$query->param('come_from_rm', 'relogin');
$query->param('rm',           'relogin');
$query->param('password',     'seekrit');

$app   = MyTestApp->new(QUERY => $query);
$app->run;

ok($app->stash->{'Seen_Run_Mode'}{'page_the_second'},  '[relogin sub to page_the_second, pass] fall through to page_the_second');
is($app->stash->{'Final_Run_Mode'}, 'page_the_second', '[relogin sub to page_the_second, pass] final page was page_the_second');
is($query->param('unusual'), $unusual_value, '[relogin sub to page_the_second, pass] unusual value survived');

undef %upload_contents;
{
    local $/;

    for my $field (qw(first_files second_files)) {
        my (@fh)        = $query->upload($field);
        my (@filenames) = $query->param($field);

        for (my $i = 0; $i < @fh; $i++) {
            my $handle = $fh[$i];
            $upload_contents{$filenames[$i]} = <$handle>;
        }
    }
}

SKIP: {
    my $num_files = keys %file_contents;
    skip "CGI uploads don't currently survive the relogin process", $num_files;
    for my $file (keys %file_contents) {
        is($upload_contents{$file}, $file_contents{$file}, "[initial query] upload file contents okay: $file");
    }
}