• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/perl

use strict;
use warnings;

#use Test::More 'no_plan';
use Test::More tests => 25;
use Test::Exception;

=begin # tests:
tests foreign key constraint prevents deletion of parent row if it exists in a
child table - uses default data from test-lib.pl
=cut

BEGIN {
    require 't/test-lib.pl';
}

my ($dbh, $dbix);

eval {
    $dbh = get_dbh()  or die 'no database handle recieved from get_dbh';
};

warn $@ if $@;

# supress error warnings to console:
local $dbh->{'RaiseError'} = 1; # default
local $dbh->{'PrintError'} = 0; # override

# do_delete() expects fk col in child table to be singular of parent table + _id
# or use args->{col}

{ # audit_request_options -> audit_request_categories:
    my %args = (
        child  => 'audit_request_options',
        col    => 'category_id',
        parent => 'audit_request_categories',
    );    
    do_delete(\%args);
}
{ # diagnoses -> diagnostic_categories:
    my %args = (
        child  => 'diagnoses',
        col    => 'diagnostic_category_id',
        parent => 'diagnostic_categories',
    );    
    do_delete(\%args);
}
{ # lab_tests -> lab_sections:
    my %args = (
        child  => 'lab_tests',
        parent => 'lab_sections',
    );    
    do_delete(\%args);
}
{ # parent_organisations -> referral_types:
    my %args = (
        child  => 'parent_organisations',
        parent => 'referral_types',
        row    => 4,
    );    
    do_delete(\%args);
}
{ # patient_case -> patients:
    my %args = (
        child  => 'patient_case',
        parent => 'patients',
    );    
    do_delete(\%args);
}
{ # patient_case -> referral_sources:
    my %args = (
        child  => 'patient_case',
        parent => 'referral_sources',
    );    
    do_delete(\%args);
}
{ # referral_sources -> parent_organisations:
    my %args = (
        child  => 'referral_sources',
        parent => 'parent_organisations',
    );    
    do_delete(\%args);
}
{ # referral_sources -> referral_types:
    my %args = (
        child  => 'referral_sources',
        parent => 'referral_types',
        row    => 3,
    );    
    do_delete(\%args);
}
{ # referrer_department -> parent_organisation:
    my %args = (
        child  => 'referrer_department',
        parent => 'parent_organisations',
    );    
    do_delete(\%args);
}
{ # referrer_department -> referrers:
    my %args = (
        child  => 'referrer_department',
        parent => 'referrers',
    );    
    do_delete(\%args);
}
{ # referrers -> referral_types:
    my %args = (
        child  => 'referrers',
        parent => 'referral_types',
    );    
    do_delete(\%args);
}
{ # requests - patient_case:
    my %args = (
        child  => 'requests',
        col    => 'patient_case_id',
        parent => 'patient_case',
    );    
    do_delete(\%args);
}
{ # requests - referrer_department:
    my %args = (
        child  => 'requests',
        col    => 'referrer_department_id',
        parent => 'referrer_department',
    );    
    do_delete(\%args);
}
{ # request_consent -> consent_options:
    my %args = (
        child  => 'request_consent',
        col    => 'consent_id',
        parent => 'consent_options',
    );    
    do_delete(\%args);
}
{ # request_specimen - specimens:
    my %args = (
        child  => 'request_specimen',
        parent => 'specimens',
    );    
    do_delete(\%args);
}
{ # request_trial -> clinical_trials:
    my %args = (
        child  => 'request_trial',
        col    => 'trial_id',
        parent => 'clinical_trials',
    );    
    do_delete(\%args);
}
{ # result_summary_options -> lab_sections:
    my %args = (
        child  => 'result_summary_options',
        parent => 'lab_sections',
    );    
    do_delete(\%args);
}
{ # screen_lab_test -> lab_tests:
    my %args = (
        child  => 'screen_lab_test',
        parent => 'lab_tests',
    );    
    do_delete(\%args);
}
{ # screen_lab_test -> screens:
    my %args = (
        child  => 'screen_lab_test',
        parent => 'screens',
    );    
    do_delete(\%args);
}
{ # screen_lab_test_detail -> screens:
    my %args = (
        child  => 'screen_lab_test_detail',
        parent => 'screens',
    );    
    do_delete(\%args);
}
{ # screen_lab_test_detail -> lab_tests:
    my %args = (
        child  => 'screen_lab_test_detail',
        parent => 'lab_sections',
    );    
    do_delete(\%args);
}
{ # users -> user_locations:
    my %args = (
        child  => 'users',
        parent => 'user_locations',
    );    
    do_delete(\%args);
}
{ # users -> user_groups:
    my %args = (
        child  => 'users',
        col    => 'group_id',
        parent => 'user_groups',
    );    
    do_delete(\%args);
}
{ # user_group_function -> user_groups:
    my %args = (
        child  => 'user_group_function',
        col    => 'group_id',
        parent => 'user_groups',
    );    
    do_delete(\%args);
}
{ # user_group_function -> user_functions:
    my %args = (
        child  => 'user_group_function',
        col    => 'function_id',
        parent => 'user_functions',
    );    
    do_delete(\%args);
}

sub do_delete {
    my $args = shift;
    
    my $parent_tbl = $args->{parent}; # warn $parent_tbl;
    my $child_tbl  = $args->{child}; # warn $child_tbl;
    my $row_number = $args->{row} || 1; # default = row #1
    my $fk_col     = $args->{col} || ''; # only supplied if non-standard <parent>_id

    if (! $fk_col) {
        $fk_col = $parent_tbl;
        $fk_col =~ s/s\Z//; # remove trailing 's'
        $fk_col .= '_id';
    } # warn $fk_col;

    my $fk_name = $child_tbl . '_ibfk'; # warn $fk_name;        

    $dbh->do( qq!ALTER TABLE `$child_tbl` ADD CONSTRAINT `$fk_name` FOREIGN
        KEY (`$fk_col`) REFERENCES `$parent_tbl` (`id`)! );

    dies_ok {
        $dbh->do( qq!delete from $parent_tbl where id = $row_number! );
    } "OK: expecting to die on delete from $parent_tbl";

    $dbh->do( qq!ALTER TABLE `$child_tbl` DROP FOREIGN KEY `$fk_name`! );
}