#!/usr/bin/env perl
# stripped-down version of Rose-DB-Object t/test-lib.pl
use strict;
use warnings;
use Data::Dumper;
use DBIx::Simple;
use LIMS::Local::Utils;
use DateTime::Format::Strptime;
use Test::WWW::Mechanize::CGIApp;
use Digest::SHA1 'sha1_base64';
#use LIMS::DB; # moved to 'require' in BEGIN block for Win32
# globals used in more than 1 method, or returned to test scripts:
our ($mech, $dbh, $dbix, $cfg, $default_userid, $default_password, $fh);
BEGIN {
use LIMS::Local::Config;
$cfg = LIMS::Local::Config->instance;
# override some local settings:
$cfg->{settings}->{have_request_audit} = 1;
$cfg->{settings}->{lab_section_sample_type} = 1;
$cfg->{settings}->{pds_proxy} = undef; # prevent PDS lookup
my $home_dir = $cfg->{path_to_app_root};
require "$home_dir/setup/lims.sql";
require "$home_dir/t/test_data.pl";
open $fh, '>' . "$home_dir/logs/mech.htm" or die $!;
$ENV{HARNESS_ACTIVE} ||= 1; # make sure it's switched on for LIMS::DB
# set for Win32 tests otherwise triggers Rose::DB error (getpwuid not implemented):
$ENV{ROSEDB_DEVINIT} = "$home_dir/config/rosedb_devinit_test.pl";
# switch ON console debug (or use locally in scripts or command line):
# $ENV{RDBO_DEBUG_ON} = 1;
# needs to be loaded *after* ROSEDB_DEVINIT env var set:
require LIMS::DB;
my $db = LIMS::DB->new_or_cached;
$dbh = $db->retain_dbh or die LIMS::DB->error; # use Data::Dumper; warn Dumper $db->dsn;
$dbix = DBIx::Simple->new($dbh);
$mech = Test::WWW::Mechanize::CGIApp->new(app => 'LIMS::Dispatch');
}
BEGIN {
# make sure HARNESS_ACTIVE env flag set for default_domain() in LIMS::DB - using default = test now so not req.
$ENV{HARNESS_ACTIVE} || die 'HARNESS_ACTIVE flag not set - cannot continue'; # paranoia rules OK!!
use vars qw($SQL_FOR_TABLE $FOREIGN_KEYS $TEST_DATA); # from test_data.pl
# make sure test_db exists:
$dbh->do( 'CREATE DATABASE IF NOT EXISTS `lims_test`' ); # too late - already fails during connect
# switch fk check off:
$dbh->do( 'SET foreign_key_checks = 0' );
foreach my $tbl ( keys %$SQL_FOR_TABLE ) { # print $tbl, "\n";
next if $tbl =~ /^_/; # not needed for tests
local $dbh->{'RaiseError'} = 1; local $dbh->{'PrintError'} = 0;
$dbh->do( qq!DROP TABLE IF EXISTS `$tbl`! );
my $sql = $SQL_FOR_TABLE->{$tbl}; # warn $sql;
$dbh->do( $sql );
}
# switch fk check back on:
$dbh->do( 'SET foreign_key_checks = 1' );
$default_userid = 'admin_fname.admin_lname';
$default_password = 'adm1n';
foreach my $t( keys %$TEST_DATA ) { # warn $t, "\n";
my $table = $t,
my $fields = $TEST_DATA->{$t}->{fields};
my $values = $TEST_DATA->{$t}->{values};
foreach my $data_set (@$values) { # warn $set, "\n";
my $i = 0;
# map field_name to its value:
my %data = map { $fields->[$i++] => $_ } @$data_set; # warn Dumper \%data;
$dbix->insert($t, \%data);
}
}
=begin # no point if can't use FK's:
# create fk's:
foreach my $fk ( sort keys %$FOREIGN_KEYS ) { # print $FOREIGN_KEYS->{$fk};
$dbh->do( $FOREIGN_KEYS->{$fk} ); # print " .. OK\n";
}
=cut
}
# messaging system -------------------------------------------------------------
# returns dfv messages ($messages->{dfv_msgs}->{$foo}):
sub get_dfv_message {
my $class = shift;
return $cfg->{msg}->{dfv_msgs}->{$class};
}
# returns not dfv mmeeages ($messages->{$foo}):
sub get_messages {
my $class = shift;
return $cfg->{msg}->{$class};
}
sub get_test_data {
return $TEST_DATA;
}
# return dfv error, formatted as specified in $cfg->{dfv_defaults}->{msg}->{format}
# (for dfv messages constructed from $cfg->{msgs}->{dfv_msgs})
# internal & external (*.t scripts) method:
sub dfv_format {
my $msg = shift;
my $template = $cfg->{dfv_defaults}->{msgs}->{format};
my $string = get_dfv_message($msg);
# something like '<span class="dfv_errors">« %s</span>', 'foo':
return sprintf $template, $string;
}
# return dfv error, formatted as specified in $cfg->{dfv_defaults}->{msg}->{format}:
# (for default messages constructed from $cfg->{dfv_defaults}->{msgs})
# internal-only method:
sub _format_dfv_string_default {
my $msg = shift;
my $dfv_msgs = $cfg->{dfv_defaults}->{msgs};
# something like '<span class="dfv_errors">« %s</span>', 'foo':
return sprintf $dfv_msgs->{format}, $dfv_msgs->{$msg};
}
#------------------------------------------------------------------------------
sub get_dbh { return $dbh; }
sub get_dbix { return $dbix; }
sub get_config { return $cfg; }
sub get_last_insert_id {
my $table = shift;
# only works if it was a DBIx::Simple action:
# my $last_insert_id = $dbix->last_insert_id(undef, undef, $table, 'id');
my $last_insert_id = $dbix->query('select max(id) from '.$table)->list;
return $last_insert_id;
}
sub get_mech {
return $mech;
}
sub get_yaml {
my $filename = shift;
my $wantarray = shift; # optional flag to return yaml array not scalar (hashref)
my %args = (
yaml_dir => $cfg->{settings}->{yaml_dir},
app_root => $cfg->{path_to_app_root},
filename => $filename,
); # warn Dumper \%args;
if ($wantarray) {
my @yaml = LIMS::Local::Utils::get_yaml(\%args); # warn Dumper @yaml;
return @yaml; # but will actually be arrayref
}
else {
my $yaml = LIMS::Local::Utils::get_yaml(\%args);
return $yaml;
}
}
sub get_formatter {
return DateTime::Format::Strptime->new(pattern => '%d.%b.%Y');
}
sub drop_tables {
my $tables = shift; # arrayref
my $dbh = get_dbh() or die 'no database handle recieved from get_dbh';
# Drop existing tables, ignoring errors
{
local $dbh->{'RaiseError'} = 0;
local $dbh->{'PrintError'} = 0;
foreach (@$tables) {
$dbh->do("DROP TABLE $_"); # or warn $dbh->errstr;
};
}
}
sub drop_and_recreate {
my $table = shift; # warn $table;
my $dbh = get_dbh() or die 'no database handle recieved from get_dbh';
=begin # no point if can't use FK's:
# delete all fk's:
foreach my $fk ( sort keys %$FOREIGN_KEYS ) {
my ($tbl) = $fk =~ /fk_(.*)/; # print Dumper $tbl;
my (@fks) = $FOREIGN_KEYS->{$fk} =~ /(\w+_ibfk_\d)/g; # print Dumper \@fks;
map { # print qq!ALTER TABLE `$tbl` DROP FOREIGN KEY `$_`!;
$dbh->do( qq!ALTER TABLE `$tbl` DROP FOREIGN KEY `$_`! ); # print " .. OK\n";
} @fks;
}
=cut
$dbh->do( "DROP TABLE $table" );
$dbh->do( $SQL_FOR_TABLE->{$table} );
=begin # no point if can't use FK's:
# re-create all fk's:
foreach my $fk ( sort keys %$FOREIGN_KEYS ) { print $FOREIGN_KEYS->{$fk};
$dbh->do( $FOREIGN_KEYS->{$fk} ); print " .. OK\n";
}
=cut
}
sub do_login {
my $userid = shift || $default_userid;
my $passwd = shift || $default_password;
my $response = $mech->get_ok('/');
# ok($response->header('Set-Cookie'), 'has cookie header');
like( $mech->cookie_jar->as_string(), qr/CGISESSID/, 'cookie was accepted' );
# confirm login box loaded:
$mech->content_contains(
'Please enter your login details',
'login box loaded',
);
### select 1st form:
$mech->form_name('login_form');
# login:
$mech->submit_form(
fields => {
authen_username => $userid,
authen_password => $passwd,
}
);
my $user_map = get_user_map($userid); # warn Dumper $user_map;
# confirm logged in:
$mech->has_tag_like(
span => qr($user_map->{first_name} $user_map->{last_name})i,
'user logged in successfully',
); # print_and_exit();
}
sub get_user_map {
my $userid = shift; # warn Dumper $userid;
my ($fname,$lname) = split '\.', $userid; # warn Dumper [$fname,$lname];
my $dbix = get_dbix();
my $sql = q!select first_name, last_name, username from users where
first_name = ? and last_name = ?!;
return $dbix->query($sql, $fname, $lname)->hash;
}
sub is_spell_check_required {
my $cfg = get_config();
return $cfg->{settings}->{require_spell_check} eq 'yes';
}
sub test_missing_required {
my $data = shift; # use Data::Dumper; warn 'here'; warn Dumper $data;
my $form_name = shift; # optional - used for multi-form pages
# test each required field:
foreach my $field ( keys %$data ) { # warn 'here'; warn $field;
# create temp hash with one field missing:
my %tmp = %$data; # clone %data
$tmp{$field} = undef; # warn 'here'; warn Dumper \%tmp;
# jump to correct form:
if ($form_name) {
$mech->form_name($form_name);
}
$mech->submit_form( fields => \%tmp ); # print_content(); exit;
# check we have dfv error:
has_dfv_errors();
has_missing();
}
}
sub has_dfv_errors {
$mech->content_contains(
get_messages('dfv_errors'),
'OK: form validation failed',
);
}
sub lacks_dfv_errors {
my $msg = shift || 'form validation passed';
$mech->content_lacks(
get_messages('dfv_errors'),
"OK: $msg",
);
}
sub has_formvalidator_error {
my $str = shift;
$mech->content_contains(
qq!<li>$str</li>!,
'OK: expected field error detected'
);
}
sub lacks_formvalidator_error {
my $str = shift;
$mech->content_lacks(
qq!<li>$str</li>!,
'OK: field error absent'
);
}
# constructed from default string $cfg->{dfv_defaults}->{msgs}->{missing}:
sub has_missing {
$mech->content_contains(
_format_dfv_string_default('missing'),
'OK: missing field(s) detected',
);
}
# constructed from default string $cfg->{dfv_defaults}->{msgs}->{missing}:
sub lacks_missing {
$mech->content_lacks(
_format_dfv_string_default('missing'),
'OK: missing field(s) not detected',
);
}
# constructed from default string $cfg->{dfv_defaults}->{msgs}->{invalid}:
sub has_invalid {
my $msg = shift || 'invalid entry detected';
$mech->content_contains(
_format_dfv_string_default('invalid'),
"OK: $msg",
);
}
# constructed from default string $cfg->{dfv_defaults}->{msgs}->{invalid}:
sub lacks_invalid {
my $msg = shift || 'invalid entry not detected';
$mech->content_lacks(
_format_dfv_string_default('invalid'),
"OK: $msg",
);
}
# constructed from custom string $cfg->{msg}->{dfv_messages}->{not_unique}:
sub has_duplicate {
$mech->content_contains(
dfv_format('not_unique'),
'OK: duplicate entry detected',
);
}
# constructed from custom string $cfg->{msg}->{dfv_messages}->{not_unique}:
sub lacks_duplicate {
$mech->content_lacks(
dfv_format('not_unique'),
'OK: duplicate entry not detected',
);
}
sub print_content {
print $fh $mech->content;
}
sub print_and_exit {
print $fh $mech->content; exit;
}
sub get_digest {
my $pwd = shift;
return Digest::SHA1::sha1_base64($pwd);
}
sub retrieve_all_records {
my ($form_name, $field_name) = @_;
$mech->form_name($form_name);
$mech->field($field_name => '%');
$mech->submit();
}
sub do_logout {
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr/logout/i, },
'logout using LogOut link on page',
);
# confirm login box loaded:
$mech->content_contains(
'Please enter your login details',
'login box re-loaded',
);
}
sub mysql_supports_innodb {
eval {
CLEAR: {
local $dbh->{'RaiseError'} = 0;
local $dbh->{'PrintError'} = 0;
$dbh->do('DROP TABLE rdbo_innodb_test');
}
$dbh->do( q!CREATE TABLE rdbo_innodb_test( id INTEGER PRIMARY KEY ) TYPE=InnoDB! );
# MySQL will silently ignore the "TYPE=InnoDB" part and create
# a MyISAM table instead. MySQL is evil! Now we have to manually
# check to make sure an InnoDB table was really created.
my $db_name = 'lims_test';
my $sth = $dbh->prepare("SHOW TABLE STATUS FROM `$db_name` LIKE ?");
$sth->execute('rdbo_innodb_test');
my $info = $sth->fetchrow_hashref;
unless (lc $info->{'Type'} eq 'innodb' || lc $info->{'Engine'} eq 'innodb') {
die "Missing InnoDB support";
}
$dbh->do('DROP TABLE rdbo_innodb_test');
};
if ($@) {
warn $@ unless($@ =~ /Missing InnoDB support/);
return 0;
}
return 1;
}
END {
foreach my $t ( keys %$SQL_FOR_TABLE ) {
#$dbh->do("DROP TABLE $t");
}
$dbh->disconnect;
}
1;
