#!/usr/bin/perl
use Time::HiRes qw(gettimeofday tv_interval);
use IPC::System::Simple qw(system);
use Test::WWW::Mechanize::CGIApp;
use WWW::Mechanize::TreeBuilder;
use Data::Printer;
use Test::More;
use strict;
use warnings;
use feature 'say';
use lib 't/lib'; # loads t/lib/LIMS/DB/Outreach files in place of lib/LIMS/DB/Outreach
=begin # tests:
=cut
BEGIN { # need to copy LIMS/DB/Outreach files and substitute db name:
my $t0 = [gettimeofday];
# make new directory t/lib/LIMS/DB/Outreach:
system( 'mkdir', '-p', 't/lib/LIMS/DB/Outreach' );
# copy files from lib/LIMS/DB/Outreach (needs to be all 1 command for shell + wild-card):
system( 'cp lib/LIMS/DB/Outreach/*.pm t/lib/LIMS/DB/Outreach/' );
# substitute 'outreach' -> 'outreach_test' for all files in new directory
# (x27 is hex for apostrophe, otherwise needs ugly escaping; make warnings
# fatal so that process dies before any tests can run):
system( q!perl -mwarnings=FATAL,all -pi -e \
's/(schema\s*=>\s*\x27outreach)/$1_test/' \
t/lib/LIMS/DB/Outreach/*.pm! );
# check all files in t/lib/LIMS/DB/Outreach have substitution, or die (0777
# is impossible hex char so line-sep changes to undef so whole file is read):
system(q!perl -0777 -ne '/outreach_test/ or die' t/lib/LIMS/DB/Outreach/*.pm!);
say sprintf 'copied Outreach DB: %.2f sec', tv_interval $t0, [gettimeofday];
require 't/test-lib.pl';
say sprintf 'finished: %.2f sec', tv_interval $t0, [gettimeofday];
}
my $dbix = get_dbix();
my $mech = get_mech();
WWW::Mechanize::TreeBuilder->meta->apply($mech);
# need to see if 'require_spell_check' is required:
my $spell_check_required = is_spell_check_required(); # warn $spell_check_required;
$dbix->dbh->do( qq!TRUNCATE TABLE outreach_test.$_! ) for qw(
request_followup
request_pack_dispatch
);
{ # new db entries:
# new specimen:
$dbix->insert('specimens',
{ sample_code => 'CMP', description => 'Outreach' });
# new screen category:
$dbix->insert('screen_category', { name => 'outreach', is_active => 'yes'});
my $category_id = get_last_insert_id('screen_category');
# new screen:
$dbix->insert('screens',
{ description => 'Outreach', category_id => $category_id, active => 'yes' });
# new test:
$dbix->insert('lab_tests',
{ test_name => 'outreach', field_label => 'Outreach', test_type=> 'panel',
lab_section_id => 1, has_results => 'no' });
# new screen_lab_test:
my $screen_id = get_last_insert_id('screens');
my $test_id = get_last_insert_id('lab_tests');
$dbix->insert('screen_lab_test',
{ screen_id => $screen_id, lab_test_id => $test_id });
}
do_login();
my $today = DateTime->today;
$mech->get_ok('/request/add_new/2'); # print_and_exit();
$mech->submit_form(
fields => {
request_number => 3,
specimen => 'pb,cmp',
referrer_code => 'C1234567',
},
); # print_and_exit();
$mech->content_contains(
q!New request successful!,
'OK: new request entered successfully',
);
$mech->get_ok('/search/=/3'); # print_and_exit();
$mech->text_contains(
q!Screened as Outreach!,
'OK: screened as expected',
); # print_and_exit();
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr(outreach)i, },
'select "outreach" link',
); # print_and_exit();
$mech->text_contains(
q!Report table!,
'OK: report page loaded',
);
$mech->form_name('reportForm');
is( $mech->value('clinical_details'), 'Outreach monitoring',
'OK: request details loaded');
# minimal fields required:
$mech->submit_form( fields => {
followup_option_id => 3, # six weeks
specimen_quality => 'adequate',
diagnosis_id => 2,
authorise => 1,
}); # print_and_exit();
$mech->submit_form(form_name => 'reportForm') if $spell_check_required; # print_and_exit();
{
my $msg = get_messages('action')->{edit_success};
$mech->has_tag_like(
p => qr($msg),
'OK: record updated successfully',
); # print_and_exit();
}
$mech->get_ok('/report/outreach/3'); # print_and_exit();
$mech->form_name('reportForm');
is( $mech->value('followup_option_id', 1), 3, 'OK: expected followup option');
{ # expected pack dispatch due date:
my $date = $today->clone->add(weeks => 6)->subtract(days => 14); # p $date;
is( $mech->look_down(id => 'pack_due')->attr('value'),
$date->strftime('%d.%b.%Y'),
'OK: expected pack dispatch due date'
); # print_and_exit();
}
# edit followup option (requires edit_outreach_data permission):
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->content_contains('Permission Denied', 'OK: expected permission denied');
{ # new user permission:
$dbix->insert('user_functions',
{ function_name => 'edit_outreach_data', active => 'yes',
function_detail => 'edit_outreach_data' });
my $user_function_id = get_last_insert_id('user_functions');
$dbix->insert('user_group_function',
{ group_id => 1, function_id => $user_function_id });
}
# logout and back in again for permission change:
do_logout();
do_login();
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->content_contains('Edit Outreach follow-up', 'OK: function now allowed');
$mech->form_name('followup');
$mech->field(followup_option_id => 4); # two years
$mech->submit; # print_and_exit();
{ # expected pack dispatch due date:
my $date = $today->clone->add(years => 2)->subtract(days => 14); # p $date;
is( $mech->look_down(id => 'pack_due')->attr('value'),
$date->strftime('%d.%b.%Y'),
'OK: expected new pack dispatch due date'
); # print_and_exit();
}
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from six weeks to two years', 'OK: history log');
# return to clinic:
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->form_name('followup');
$mech->field(followup_option_id => 5); # return to clinic
$mech->submit; # print_and_exit();
is( $mech->look_down(id => 'pack_due')->attr('value'), '01.Jan.1999',
'OK: default date for no pack dispatch'
);
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from two years to return to clinic', 'OK: history log');
# followup option = other:
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->form_name('followup');
$mech->field(followup_option_id => 6); # other
$mech->submit; # print_and_exit();
is( $mech->look_down(id => 'pack_due')->attr('value'), '01.Jan.1999',
'OK: default date for no pack dispatch'
); # print_and_exit();
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from return to clinic to other', 'OK: history log');
# return immediately:
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->form_name('followup');
$mech->field(followup_option_id => 1); # immediately
$mech->submit; # print_and_exit();
{ # expected pack dispatch due date:
my $date = $today->clone->subtract(days => 14); # p $date;
is( $mech->look_down(id => 'pack_due')->attr('value'),
$date->strftime('%d.%b.%Y'),
'OK: expected new pack dispatch due date'
); # print_and_exit();
}
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from other to immediately', 'OK: history log');
done_testing();
