=begin nd
Class: LIMS::Local::Utils
A collection of functions to perform various common and/or repetitive tasks required by other applications eg validation of dates, conversion of dates to other formats, generation of html symbols, trimming white space, etc.
Exports functons into callers namespace using EXPORT_OK.
=cut

package LIMS::Local::Utils;

use strict;
use warnings;

# stopped exporting - methods called explicitly now
# require Exporter;
# our @ISA = qw(Exporter);

use IO::All;
use YAML::Tiny;
use Time::ParseDate;
use Archive::Extract;
use Digest::SHA1 'sha1_base64'; # use Digest::MD5 'md5_hex';
use DateTime::Format::DateParse;
use CGI::Simple::Standard qw( escapeHTML );
use FindBin qw($RealBin); # works for lims_server.pl & hilis3_convert.pl, but not fastcgi
use DateTime; DateTime->DefaultLocale('en_GB'); # set default locale
use Date::Calc qw(Decode_Date_EU Day_of_Week Add_Delta_Days Delta_Days Today
	This_Year Today_and_Now);

use LIMS::Local::Debug;
use Data::Dumper;

# FindBin can't cope with app being called from different locations relative to home dir:
sub find_home {
    my $path_to_app;

    # NB: $INC[0] set by lims_server.pl 'use lib', or mod_perl config:
    foreach (@INC) { # warn 'INC:'. $_ . "\n";
        if (-e "$_/LIMS.pm") { # "$_/lib/LIMS.pm"
            $path_to_app = $_ and last;
        }
    } # warn 'PATH_TO_APP:'. $path_to_app;

#open my $fh, '>' . '/home/raj/www/apps/HMDS/trunk/path.log' or die $!;
#print $fh 'path_to_app: ' . $path_to_app, "\n";
#print $fh 'RealBin: ' . $RealBin, "\n";

    # if $INC[0] set by lims_server.pl, need to strip trailing 3 dirs:
    if ($path_to_app =~ m!(\.\./lib)$!) { # warn 'HERE'; # warn '$INC[0] set by lims_server.pl';
        $path_to_app =~ s/(\/\w+\/$1)$//; # eg /path/to/app/script/../lib -> /path/to/app
    }
    # if $INC[0] set by mod_perl, need to remove trailing /lib:
	# CHANGED 'elsif' to 'if' IN CASE TRAILING '/lib' STILL INTACT (eg called from cron):
    if ($path_to_app =~ m!(/?lib)$!) { # warn 'HERE'; # warn '$INC[0] set by mod_perl';
        $path_to_app =~ s/($1)$//; # eg /path/to/app/lib -> /path/to/app
    }

	# fix for Win32 - returns empty $path_to_app otherwise
	$path_to_app ||= '.'; # warn 'PATH_TO_APP:'. $path_to_app;

    return $path_to_app;
}

=begin nd
Function: check_date
Evaluates string with Date::Calc::Decode_Date_EU. Catalyst::Controller::FormBuilder::validate() require a true value for a valid field, so returns true ( 1 ) if date is decipherable and not in future, otherwise returns 0
=cut

sub check_date {
	my $date = shift; # DEBUG('DATE:', $date);

    # first check we have 4-digit year:
    return 0 unless $date =~ /\W\d{4}$/; # check for non-word character (dot, hyphen, space, etc) followed by 4 digits

    my $date_is_valid; # becomes true if Decode_Date_EU can decode date (as scalar takes last output from function = day)

    # wrap it in eval so we don't die if date IS invalid:
	eval { $date_is_valid = Decode_Date_EU($date) }; # DEBUG('date_is_valid:', $date_is_valid);

    # if date decoded OK, check it for future, otherwise return 0:
    $date_is_valid || return 0; # DEBUG ('date confirmed valid');

    # returns true if date >= Today():
	my $date_is_future = _date_is_future($date);  DEBUG ("date_is_future: $date_is_future");

    # need to return true value if date is valid (no error and date not in future):
	return $date_is_future ? 0 : 1;
}

=begin
Function: check_date
Evaluates string with Time::ParseDate::parsedate(). Converts a valid (UK-style) date to number of seconds since the epoch (1970-01-01). If called in array context, parsedate() returns an error element which contains the error string if date invalid. Catalyst::Controller::FormBuilder::validate() require a true value for a valid field so cannot return the error code. Method returns true (1) if date is valid, otherwise 0. Only reliable for 4-digit years between 1902 and 2038 (not at all for 2-digit years due to assumptions).
  Using Decode_Date_EU method instead
=cut

sub _check_date {
	my $date = shift;


# variable: to_seconds
# number of seconds since the epoch (1970-01-01) if date is valid
# variable: $error
# contains error message if date is invalid, otherwise undef
# VALIDATE - force validation; PREFER_PAST -  assume past when year or day of week is ambiguous (allows dd-mm-yy when yy >= current yy)
    my ( $to_seconds, $error ) =
      Time::ParseDate::parsedate( $date, UK => 1, VALIDATE => 1 ); #, PREFER_PAST => 1 - best to have unambiguous dates

    # returns true if date >= Today():
    my $date_is_future = _date_is_future($date); # DEBUG ("date_is_future: $date_is_future");

    # need to return true value if date is valid (no error and date not in future):
    return ( $error || $date_is_future ) ? 0 : 1;
}

=begin nd
Function: date_to_mysql
Converts an EU formatted date to MySQL format (yyyy-d-m) if date is decipherable by Decode_Date_EU, or undef if not.
Need to wrap in eval and return undef if @!
=cut

sub date_to_mysql { # could use MySQL::DateFormat->toMySQL, but requires '-' or '/' separators
	  my $date = shift || return;

	  return join '-', Decode_Date_EU($date);
}

=begin nd
Function: to_datetime
Converts hashref containing year, month & day values to a DateTime object ( eg 1923-02-01T00:00:00') using DateTime. Assumes date has been validated with Decode_Date_EU. Gives correct DateTime->ymd for all 4-digit years.
=cut

sub to_datetime {
    my $data = shift; # hashref

    # return safely if no date params passed:
    return unless grep $data->{$_}, qw( day month year );

    # check all required values present:
    map {
        $data->{$_} or die "No $_ value passed to LIMS::Local::Utils::to_datatime() function";
    } qw( day month year );

    return DateTime->new( year => $data->{year}, month => $data->{month}, day => $data->{day} );
}

=begin nd
Function: to_datetime_using_datecalc
Converts an EU formatted date to a DateTime object ( eg 1923-02-01T00:00:00') using DateTime. Assumes date has been
validated with Decode_Date_EU. Gives correct DateTime->ymd for all 4-digit years.
=cut

sub to_datetime_using_datecalc { # uses Decode_Date_EU & DateTime
	my $date = shift || return;

    my ( $yr, $month, $day ) = Decode_Date_EU($date);

    return DateTime->new( year => $yr, month => $month, day => $day );
}

=begin nd
Function: to_datetime_using_parsedate
Converts an EU formatted date to a DateTime object (eg 1983-02-01T00:00:00') using Time::ParseDate() and DateTime::from_epoch().
Can handle abbreviated month names (Jan Feb) and numerical months ( 1 - 12 ). But parsedate can only handle years ranging 1902 to 2038.
Two-digit years unreliable due to assumptions - DateTime->ymd switches from 2000's to 1900's after 38 (ie 38 -> 2038, 39 -> 1902!)
Need to specify time_zone either in parsedate() or from_epoch() methods or dates during BST are ajusted -1hr causing date shift, eg:
13.4.1947 becomes 1947-04-12T23:00:00
=cut

sub to_datetime_using_parsedate { # uses Time::ParseDate
	my $date = shift || return;

    # dump all time_zones to file:
    # my @zones = DateTime::TimeZone->all_names; DEBUG @zones;

    # need to specify time_zone here or in from_epoch() or summer dates adjusted -1hr causing date shift:
    my ( $to_seconds, $error ) =
      Time::ParseDate::parsedate( $date, UK => 1, GMT => 1 );

    # this should not happen as date already validated:
    die $error if $error;

    # need to specify time_zone here or in parsedate(), or summer dates adjusted -1hr causing date shift:
    return DateTime->from_epoch( epoch => $to_seconds, );    # time_zone => 'Europe/London'
}

=begin nd

Function: to_datetime_using_strptime
Converts a date to a DateTime object (eg 1923-02-01T00:00:00') using DateTime::Format::Strptime.
Can handle dates before epoch (1/1/1970), but requires dates to match a specified pattern, eg %d\W%m\W%Y.
=cut

sub to_datetime_using_strptime {    # uses DateTime::Format::Strptime
    my $date = shift || return;

    my %config = (
        pattern   => '%d\W%m\W%Y',
        locale    => 'en_GB',
        time_zone => 'GMT',
        on_error  => 'croak',
    );

    my $dt = new DateTime::Format::Strptime(%config);

    return $dt->parse_datetime($date);
}

=begin nd
Function: split_labno
Extracts and returns numerator & 4-digit yr from Lab Number
=cut

sub split_labno {
    my $labno = shift or return;

    my ( $numerator, $yr ) = $labno =~ m!^[A-Z]?(\d+)/?(\d{2})?$!i;

    $yr ||= ( localtime() )[5] - 100;    # assume current year if null

    return ( $numerator, $yr + 2000 );
}

=begin nd
Function: pretty_nhs_no
Splits and returns NHS number in ddd ddd dddd format
=cut

sub pretty_nhs_no {
    local $_ = shift;

    my (@nhsno) = /(\d{3})(\d{3})(\d{4})/;    # DEBUG (@nhsno);

    return sprintf '%s %s %s', @nhsno;
}

=begin nd
Function: sha1_digest
Returns encrypted string:
=cut

sub sha1_digest {
	my $str = shift; # warn $str;

    return Digest::SHA1::sha1_base64($str); # Digest::MD5::md5_hex($str)
}

=begin nd
Function: check_nhsno
Validates NHS number using the Modulus 11 algorithm. The tenth digit of an NHS number is a check digit.
+ multiply each of the first nine digits by a weighting factor 1 -> 10, 2 -> 9, 3 -> 8 .. 9 -> 2
+ add the results of each multiplication together
+ divide the total by 11 and establish the remainder
+ subtract the remainder from 11 to give the expected value of the check digit
+ if remainder is less than 10 AND matches the check digit then the submitted NHS number is VALID

Function returns 1 if valid, and undef if invalid or not 10-digits.

See also: http://www.govtalk.gov.uk/gdsc/html/frames/NHSnumber-2-0-Release.htm
=cut

sub check_nhsno {
    my $nhsno = shift;    # _dump(Dumper $nhsno);

    $nhsno =~
      s/\s+//g;    # remove spaces if nhs_no submitted in nnn nnn nnnn format

    return unless length $nhsno == 10;    # require 10 consecutive numbers only

    my $product;

    # sum of (each of the first nine digits * weighting factor):
    for ( 0 .. 8 ) {                      # 1st 9 digits of NHS no
        $product += ( substr( $nhsno, $_, 1 ) * ( 10 - $_ ) );
    }

# Divide $product by 11 and establish the remainder.
# Subtract the remainder from 11 to give
# the check digit. If the result is 11 then a check digit of 0 is used.
    my $check_digit = $product % 11
      ?                                   # if $product / 11 is non-zero:
      11 - ( $product % 11 )
      :     # $check_digit = 11 minus remainder of $product / 11
      0;    # $check_digit = zero

    # returns true (valid) if:
    return $check_digit ==
      substr( $nhsno, 9, 1 )    # $check_digit matches the 10th digit, and
      && $check_digit != 10;    # invalid if $check_digit == 10
}

# requires dob & ref_date as dt objects:
sub calculate_age {
	my ($dob, $ref_date) = @_; # warn Dumper [$dob, $ref_date];
	
	return 0 unless $dob && $ref_date # also must be DT objects:
		&& ref $dob eq 'DateTime' && ref $ref_date eq 'DateTime';
	
	# my $age = $ref_date->year - $dob->year - ( $dob->day_of_year > $ref_date->day_of_year );
	my $age = ($ref_date - $dob)->in_units('years'); # warn $age; # DateTime::Duration function
	return $age;
}

# shared by ReportUpdate::do_request_report() & incomplete_requests.pl cron
sub diagnosis_confirmation_required {
	my $args = shift; # expect keys = screen, specimen, lab_tests, lab_sections
	
=begin # a "final_diagnosis" confirmation IS required if:
	1) request.status = 'authorised' (already been tested for)
	2) no outstanding tests
	3) has a cytogenetics, molecular or FISH results summary
	4) has not been screened as:
		Molecular miscellaneous
		Chimerism sample
		PNH
		Rheumatoid arthritis
		CML follow-up (post-BMT, imatinib, interferon, STI) on PB sample
		CMPD pres & follow-up on PB sample with JAK2 as sole test
=cut

	my $src = find_home() . "/config/.local/diagnosis_confirm.yml";
	return 0 unless (-e $src);  # eg function not configured
	my $yaml = YAML::Tiny->read($src)->[0]; # warn Dumper $yaml;

	my $specimen = $args->{specimen}; # array(ref) of sample_codes
	my $lab_test = $args->{lab_test}; # AoH (keys = test_name & status)
	my $section  = $args->{section};  # array(ref) of lab_section names
	my $screen   = $args->{screen};   # str
	
	# get list of lab_test names:
	my @lab_tests = map $_->{test_name}, @$lab_test; # warn Dumper \@lab_tests;

	{ # exempted screens with any sample type:
		# NB - already checked in incomplete_requests.pl
		my $exempt_screens = $yaml->{exempt_all_sample_types}; # arrayref
		return 0 if grep $screen eq $_, @$exempt_screens;		
	} # warn 'here';
	
	{ # exempted screens with specific sample type:
		my $data = $yaml->{exempt_if_sample_type}; # hashref
		while ( my($exempt_screen, $exempt_specimen) = each %$data ) {
			return 0 if $screen eq $exempt_screen
				&& lc(join '', @$specimen) eq lc $exempt_specimen;
		}
	} # warn 'here';
	
	{ # # exempted screens with specific sample type and lab test:
		my $data = $yaml->{exempt_if_sample_type_and_lab_test}; # hashref
		while ( my($exempt_screen, $d) = each %$data ) {
			return 0 if
				$screen eq $exempt_screen &&
				lc(join '', @$specimen) eq $d->{sample} &&
				lc(join '', @lab_tests) eq $d->{test_name};
		}
	} # warn 'here';
	
	{ # require result_summary from molecular, cytogenetics or FISH sections:
		# NB - already checked in incomplete_requests.pl
		my $lab_sections = $yaml->{lab_sections}; # arrayref
		my %map = map { $_ => 1 } @$lab_sections; # create hash from array(ref)
		return 0 unless grep $map{$_}, @$section;
	} # warn 'here';
	
	{ # require all lab_test status = complete:
		# NB - already checked in _diagnosis_confirmation_required()
		my @status = map $_->{status}, @$lab_test; # warn Dumper \@status;
		return 0 if grep $_ ne 'complete', @status;		
	} # warn 'here';
	
	# OK, not an exempt initial_screen/specimen combination, do have necessary
	# result summary & all lab_tests complete so DO need confirmation:
	return 1;	
}

# return postcode in WWd(d) dWW format (or 0 if invalid):
sub format_postcode {
	my $post_code = shift || return 0;

	$post_code =~ s/\s//g; # remove all spaces
    $post_code = uc $post_code; # lower case
    
    # see also http://github.com/JeremyJones/Regexp--Common/tree/master/lib/
    my $regex = qr(^([A-Z]{2}[0-9]{1,2})([0-9]{1}[A-Z]{2})$);
    # <http://www.wellho.net/resources/ex.php4?item=q803/pcode>:
    # my $regex = qr(^(([A-Z]{1,2})\d[0-9A-Z]?) +(\d[A-Z]{2})$);
    
    # put space back 4th from end
	my $formatted_postcode = join ' ', $1, $2 if $post_code =~ $regex;

	return $formatted_postcode || 0; # for validator
}

# extracts zip contents & returns a contents table
# expects upload dir & <file name>.zip
sub unzip_file {
	my $args = shift; # warn Dumper $args;
	
	my $target_dir = $args->{target_dir}; # unzip into upload dir
	my $filename   = $args->{filename}; # ie <file name>.zip	
	
	$filename =~ s/\s/_/g; # substitute spaces

	my $src_file = join '/', $target_dir, $filename;
	
	my $unzip = '/usr/bin/unzip';
    my @zip_contents = `$unzip -l $src_file`; # get list of files in zip for display
	
    # -a to convert DOS txt file line-endings 
    # -b to convert all files as binary
    # -j to ignore directory structure
    # -o to overwrite
    # -d or tries & fails to unzip to cgi-bin
	
	# problem with /usr/bin/unzip extracting some binaries as text
#    `$unzip -ajo $src_file -d $target_dir` || die "Problem: ", $? >> 8, "\n";

	my $archive = Archive::Extract->new(archive => $src_file);
    my $ok = $archive->extract(to => $target_dir) or die $archive->error;
	
	return \@zip_contents;
}

=begin nd
Function: delta_business_days
Returns number of business days between two dates (submitted format??).
See Date::Calc - How can I calculate the difference in days between dates, etc
=cut

sub delta_business_days { # Date::Calc - How can I calculate the difference in days between dates, etc
    my ( $d0, $d1 ) = @_;

    my @d0 = split '-', $d0;    # DEBUG (\@d0);
    my @d1 = split '-', $d1;    # DEBUG (\@d1);

    my ( $dow1, $dow2, $diff, $temp );

    my $minus = 0;
    my $result = Delta_Days( @d0, @d1 );

    if ( $result != 0 ) {
        if ( $result < 0 ) {
            $minus  = 1;
            $result = -$result;
            $dow1   = Day_of_Week(@d1);
            $dow2   = Day_of_Week(@d0);
        }
        else {
            $dow1 = Day_of_Week(@d0);
            $dow2 = Day_of_Week(@d1);
        }
        $diff = $dow2 - $dow1;
        $temp = $result;
        if ( $diff != 0 ) {
            if ( $diff < 0 ) {
                $diff += 7;
            }
            $temp -= $diff;
            $dow1 += $diff;
            if ( $dow1 > 6 ) {
                $result--;
                if ( $dow1 > 7 ) {
                    $result--;
                }
            }
        }
        if ( $temp != 0 ) {
            $temp /= 7;
            $result -= ( $temp << 1 );
        }
    }

    if   ($minus) { return -$result; }
    else          { return $result; }
}

sub delta_last_working_day {
    my $delta = '-1';

    until ( Day_of_Week( Add_Delta_Days( Today(), $delta ) ) < 6 ) {
        $delta--;
    }

    return $delta;
}

sub last_working_day { # receives value calculated in delta_last_working_day(), returns date in EU format
    my $delta = shift;

    return join '-',
      reverse Add_Delta_Days( Today(), $delta )
      ;  # $delta always negative so use Add_Delta_Days
}

sub symbolise {    # transform eg 10/9/l & /ul
    my $string = shift || return; # warn $string;

    # first escapeHTML:
    my $formatted = escapeHTML($string); # warn $estring;

    $formatted =~ s/(\d)\/ul/$1\/&micro;L/ig;    # /ul
    $formatted =~ s/10\/(6|9)\/(l|kg)/10<sup>$1<\/sup>\/$2/ig; # 10/9/l; 10/6/kg; etc
    $formatted =~ s/10\^(\d)/10<sup>$1<\/sup>/g;         # 10^6; 10^9; etc
	
    # return escapeHTML'd string:
    return $formatted;
}

sub trim {    # remove leading & trailing spaces
    local $_ = shift;

    s/^\s+//;
    s/\s+$//;

    return $_;
}

sub this_year {
    return This_Year;
}

sub time_now {
    return DateTime->now(time_zone => 'Europe/London');
}

sub today {
  return DateTime->today;
}

# converts 4-digit year to date expression hashref useable by MySQL & SQLite:
sub year_to_date_expression {
    my $year = shift || return;

    my $first_day_of_year = DateTime->new(year => $year, month =>  1, day =>  1)->ymd;
    my $last_day_of_year  = DateTime->new(year => $year, month => 12, day => 31)->ymd;

    return { '-between' => [ $first_day_of_year, $last_day_of_year ] };
}

=begin nd
Function: _date_is_future
Expression Delta_Days( @test_date, @today ) evaluates to positive if 2 dates in chronological order, zero if both dates the same,
and negative if first date AFTER second. Function returns true if Delta_Days() evalutes to negative. Uses Date:Calc which can handle dates
> 19/1/2038. Time::ParseDate does not work for dates > 19/1/2038 (UNIX epoch date).
=cut

sub _date_is_future {
    my $date = shift;    # from check_date()

    my @decoded_date = Decode_Date_EU($date);    # DEBUG (@decoded_date);

    return 1
      unless @decoded_date
    ;    # or fatals in Delta_Days() if @decoded_date undef due to invalid date

# return value of expression 'Delta_Days() < 0' - ie true if Delta_Days is negative:
    return Delta_Days( @decoded_date, Today() ) < 0;
}

=begin # would work except parse_datetime() assumes eg 21.2.08 = American date - need to supply 21.Feb.08 for EU dates
sub _date_is_future {
    my $date = shift;

    my $date  = DateTime::Format::DateParse->parse_datetime( $date ); DEBUG( $date);
    my $today = DateTime->today(); DEBUG $today;

    my $delta = DateTime->compare($date, $today); DEBUG "delta:$delta";
}
=cut

=begin # returns true if date > today # NB Time::ParseDate DOES NOT WORK FOR DATES > 19.1.2038 !!
sub _date_is_future {
	my $seconds_to_date = shift || return; # $to_seconds from Time::ParseDate::parsedate($date)

	my $seconds_to_now = Time::ParseDate::parsedate("today"); # DEBUG("seconds_to_now:$seconds_to_now");

	# $delta will be positive if $date before or equal to today, and negative if after today:
	my $delta = $seconds_to_now - $seconds_to_date;  DEBUG("delta: $seconds_to_now minus $seconds_to_date");

	# return true if $delta < 0:
	return $delta < 0 ? 1 : 0;
}
=cut

1;