
=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 JSON; # will load JSON::XS if available
use Clone;
use IO::All;
use Try::Tiny;
use Crypt::CBC; # requires Crypt::DES also
use YAML::Tiny;
use List::Util;
use Array::Diff;
use Math::Round;
use HTML::Escape;
use Sub::Current;
use List::Compare;
use Math::SigFigs;
use Data::Traverse;
use Number::Format;
use Time::ParseDate;
use Sort::Naturally;
use DateTime::HiRes;
use List::MoreUtils;
use Archive::Extract;
use Text::Wrap qw(wrap);
use Digest::SHA1; # use Digest::MD5 qw(md5_hex sha1_base64)
use HTTP::BrowserDetect;
use DateTime::Format::Strptime;
use DateTime::Format::DateParse;
use FindBin qw($RealBin); # works for lims_server.pl & hilis3_convert.pl, but not fastcgi
use Locale::Maketext::Simple;
use Lingua::EN::Numbers qw(num2en);
use Data::Password::zxcvbn qw(password_strength);
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;
use Data::Printer; # alias => 'ddp';

use Date::Calendar;
use Date::Calendar::Profiles qw( $Profiles ); # warn Dumper $Profiles->{GB};

my %_CACHE_; # for Date::Calendar object

#-------------------------------------------------------------------------------
# use CGI::Simple::Standard qw(escapeHTML); # escapeHTML hangs render_view symbolise()
# in new print_run; need to create CGI object outside symbolise() to function, in
# dev server (OK in fastcgi) otherwise it hangs without returning from symbolise():
# !!!! cannot have global CGI::Simple object here or it prevents scripts using
# CGI::Simple Vars() - get $vars = {}; global CGI *does* work, or use CGI::Simple
# object localised to symbolise(), or replace with HTML::Escape::escape_html
# my $cgi = CGI::Simple->new; # clobbers params in cgi scripts using CGI::Simple
#-------------------------------------------------------------------------------

# 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; # warn 'DATE:', $date;
	my $future_ok = shift; # warn $future_ok; # optional - allows future dates

    # 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) }; # warn 'date_is_valid:', $date_is_valid;

    # if date decoded OK, check it for future (unless allowed):
    return 0 unless $date_is_valid; # DEBUG ('date confirmed valid');
	return 1 if $future_ok; # ie date is ok & no need to test for future

    # returns false if date <= today, true if > today:
	my $date_is_future = _date_is_future($date); # warn "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; # returns opposite of whether date is future
}

=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);
}

# converts mysql date to datetime, but wraps in try/catch & returns default date on err
sub mysql_parse_date {
	my ($date, $default) = @_;

	my $dt = try {
		DateTime::Format::MySQL->parse_date($date);
	} catch {
		warn "date error: $_"; # not $@
		DateTime::Format::MySQL->parse_date($default);
	};
	return $dt;
}

=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; # warn $date;

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

    # eval to protect DT object creation if Decode_Date_EU fails (eg FV_and() in validation):
    eval { 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 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.
Expects pattern supplied.
=cut

sub to_datetime_using_strptime {    # uses DateTime::Format::Strptime
    my $date    = shift || return;
	my $pattern = shift; # requires pattern or will die trying to parse date

    my %config = (
        pattern   => $pattern,
        locale    => 'en_GB',
        time_zone => 'GMT',
        on_error  => 'croak',
    );

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

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

sub to_datetime_using_dateparse { # uses DateTime::Format::DateParse
    my $date = shift || return;
    eval { DateTime::Format::DateParse->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;

    my $sha1 = Digest::SHA1->new;
    $sha1->add($str);
    return $sha1->b64digest; # same as:
    # 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; # allows too many "Argument 'foo' isn't numeric" errs
    # check have 10 chars - digits only:
    return 0 unless $nhsno =~ /^\d{10}$/;

    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 ) # = 11 minus remainder of $product / 11
      : 0; # = 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
}

sub sig_figs { # from http://www.indo.com/distance/dist.pl sub round_to_3():
	my $num = shift || return; # warn Dumper $num;	 # value to round

    return $num unless $num > 0; # to protect against submission of '0.' error

	my $lg = int( log(abs($num)) / log(10.0) ); # log base 10 of num

	my $round = 10 ** ($lg - 2); # warn Dumper [$num, $lg, $round, $num / $round];

	return int($num / $round + 0.5) * $round;
}

sub mean_value { List::Util::sum(@_)/@_; } # will get divide-by-zero error if @_ undef - use defined @_ ?

sub sum_list {
    my $vals = shift; # warn Dumper $vals; # arrayref
    List::Util::sum(@$vals);
}

sub round_value { Math::Round::round(@_) }

sub nearest_value { Math::Round::nearest(@_) }

sub format_sig_figs {
    my ($num, $n) = @_;

    return FormatSigFigs($num, $n);
}

sub format_number { Number::Format::format_number(@_) }

sub encrypt { # Crypt::CBC
    my ($str, $key) = @_;

	my $cipher = try { # less likely that decrypt() to throw error
		Crypt::CBC->new({ key => $key })->encrypt_hex($str);
	} catch {
		warn $_; # not $@
		0; # returns empty
	};
	return $cipher;
    #my $cipher = Crypt::CBC->new({ key => $key });
    #return $cipher->encrypt_hex($str);
}

sub decrypt { # Crypt::CBC
    my ($str, $key) = @_; # warn Dumper [$str, $key];

	my $cipher = try { # localise error in case user supplies invalid key:
		Crypt::CBC->new({ key => $key })->decrypt_hex($str);
	} catch {
		warn $_; # not $@
		0; # returns empty
	};
	return $cipher;
    #my $cipher = Crypt::CBC->new({ key => $key });
    #return $cipher->decrypt_hex($str);
}

sub get_specimens {
    my $str = shift; # warn $str;
    # split on any non-word char (don't use \W, don't want '_')
#    my @specimens = split /[^A-Za-z]+/, $str; # warn Dumper \@specimens;
    my @specimens = split /[\,\.\s]+/, $str; # warn Dumper \@specimens;
    return \@specimens;
}

# 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;
}

# flatten internal hashrefs to arrayrefs eg foo => { bar = 2, baz => 1 } to foo => [ 'bar', 'baz' ]
sub convert_hashrefs_to_arrayrefs { # http://scsys.co.uk:8007/564743
	my $input = shift; # warn Dumper $input; # HoH, or hashref if resubmitted

	my $array = [];
	my $out   = {};

	for my $key ( keys %$input ) {
		if ( ref $input->{$key} eq 'HASH' ) {
			$out->{$key} = ROUTINE->($input->{ $key }); # Sub::Current function for name of current sub
		}
		else {
			push @$array, $key;
		}
	}
	return scalar (@$array) ? $array : $out;
}

sub compare_hashes {
    my ($a, $b) = @_; # 2 hashrefs
    my $json = JSON->new->canonical; # warn Dumper [$json->encode($a),$json->encode($b)];
    return ( $json->encode($a) eq $json->encode($b) ); # returns true if identical
}

sub n_sort { # don't redefine Sort::Naturally::nsort()
    my $ref = shift; # warn Dumper $ref; # arrayref
    return Sort::Naturally::nsort(@$ref);
}

sub n_sorts { # from Sort::Naturally source code alternative sorting functions
    return @_ if @_ < 2;   # Just to be CLEVER.

    my($x, $i);  # scratch vars

    # And now, the GREAT BIG Schwartzian transform:
    map
        $_->[0],

        sort {
            # Uses $i as the index variable, $x as the result.
            $x = 0;
            $i = 1;

            while($i < @$a and $i < @$b) {
                last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
                ++$i;
                last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
                ++$i;
            }
            $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
            # unless we found a result for $x in the while loop,
            #  use length as a tiebreaker, otherwise use cmp
            #  on the original string as a fallback tiebreaker.
        }

        map {
            my @bit = ($x = defined($_) ? $_ : '');

            while(length $x) {
                push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
                push @bit, ($x =~ s/^(\d+)//s) ?    $1  :  0;
            }

            # End result: [original bit, (text, number), (text, number), ...]
            # Minimally:  [0-length original bit,]
            # Examples:
            #    ['10'         => ''   ,  10,              ]
            #    ['fo900'      => 'fo' , 900,              ]
            #    ['foo10'      => 'foo',  10,              ]
            #    ['foo9.pl'    => 'foo',   9,   , '.pl', 0 ]
            #    ['foo32.pl'   => 'foo',  32,   , '.pl', 0 ]
            #    ['foo325.pl'  => 'foo', 325,   , '.pl', 0 ]
            #  Yes, always an ODD number of elements.

            \@bit;
        }
    @_;
}

sub get_unique_elements {
    my $array = shift;

    my @unique_elements = List::MoreUtils::uniq(@$array);
    return \@unique_elements;
}

sub get_array_diff { # returns integer equivalent to number of diffs between 2 arrays
    my ($a, $b) = @_; # warn Dumper [$a, $b]; # 2 arrayrefs

    my $lc = List::Compare->new($a, $b);
    my $symdiff = $lc->get_symmetric_difference; # warn 'symdiff:'.$symdiff;
    return $symdiff; # in scalar context is array size
}

sub array_diff_count {
    my ($a, $b) = @_; # warn Dumper [$a, $b]; # 2 arrayrefs

	my $n = Array::Diff->diff($a, $b)->count; # warn $n;
	return $n;
}

sub is_array_subset { # returns true if 1st array is subset of (or same as) 2nd array
    my ($a, $b) = @_; # warn Dumper [$a, $b]; # 2 arrayrefs

    my $lc = List::Compare->new($a, $b);
    my $is_subset = $lc->is_LsubsetR; # warn Dumper $is_subset;
    return $is_subset;
}

sub has_array_common_elements { # returns true if any element is common to both arrays
    my ($a, $b) = @_; # warn Dumper [$a, $b]; # 2 arrayrefs

    my $lc = List::Compare->new($a, $b);
    my @ary = $lc->get_intersection; # warn Dumper \@ary;
    return scalar @ary; # returns true value if @ary exists
}

sub check_password_strength {
    my $password = shift; # warn $password;
    # Data::Password::zxcvbn 'password_strength':
    my $zxcvbn = password_strength($password); # p $zxcvbn;
    my %h = (
        password_length => length $password,
        guesses_num2en  => num2en( $zxcvbn->{guesses} ), # Lingua::EN::Numbers
        guesses_log10   => $zxcvbn->{guesses_log10},
        guesses_int     => $zxcvbn->{guesses},
    );
    {
        my %score_table = ( # adapted from original for HILIS unthrottled/fast-hash
            0 => 'too easily guessable, risky password',
            1 => 'very guessable, affords little protection from online '
                . 'attacks and virtually no protection from offline attacks',
            2 => 'somewhat guessable, affords limited protection from online '
                . 'attacks and negligible protection from offline attacks',
            3 => 'safely un-guessable, affords strong protection from online '
                . 'attacks and moderate protection from offline attacks',
            4 => 'very un-guessable, affords strong protection from '
                . 'both online and offline attacks',
        );
        my $score = $zxcvbn->{score};
        $h{strength_summary} = $score_table{$score};
    }
    {
        my $ctd = $zxcvbn->{crack_times_display}; # p $ctd;
        # use Locale::Maketext::Simple loc() to convert crack_times_display output:
        my $loc = sub { my $ref = $ctd->{$_[0]}; loc(@$ref) };
        my %crack_times = (
            online => {
                rate_limited => &$loc('online_throttling_100_per_hour'),
                unthrottled  => &$loc('online_no_throttling_10_per_second'),
            },
            offline => {
                slow_hash => &$loc('offline_slow_hashing_1e4_per_second'),
                fast_hash => &$loc('offline_fast_hashing_1e10_per_second'),
            },
        );
        $h{estimated_crack_times} = \%crack_times;
    }
    # add new key 'results' to $zxcvbn:
    $zxcvbn->{results} = \%h;
    return $zxcvbn;
}

sub get_complement { # Get those items which appear (at least once) only in the second list.
    my ($a, $b) = @_; # warn Dumper [$a, $b]; # 2 arrayrefs

    my $lc = List::Compare->new($a, $b);
    my @ary = $lc->get_complement; # warn Dumper \@ary;
    return \@ary;
}

sub get_min_val {
    my $list = shift;
    return List::Util::min(@$list);
}

sub get_max_val {
    my $list = shift;
    return List::Util::max(@$list);
}

sub get_first_index {
	my ($item, $ref) = @_;
	return List::MoreUtils::firstidx { $_ eq $item } @$ref; # alias first_index()
}

sub calculate_composite_p53 {
    my $data = shift; # warn Dumper $data;

    my $str = 'p53' . $data->{p53};
	$str .= 'p21' . $data->{p21} if $data->{p21}; # warn $str;

	$str =~ s!p53\+(/\-)?p21\-!deregulated!;  # p53+ or +/-; p21-
	$str =~ s!p53\+(/\-)?p21\+(/\-)?!normal!; # p53+ or +/-; p21+ or +/-
	$str =~ s!p53\-(p21[\+\-/]+)?!neg!;       # p53-; p21 +, +/- or -, or p21 result null

    return $str;
}

# extract eg FC12800701, 1234567890, etc from storage vialId string:
sub extract_storage_vial_ids {
    local $_ = shift;
    my (@ids) = /([A-Z]{2}\d{8}|\d{10})/g;
    return \@ids;
}

# convert stones & pounds to kg:
sub convert_imperial {
	my $data = shift || return;

    my $stones = $data->{imperial_stones} || return; # can't be null

    my $kg = $stones * 6.35029318;

    if ( my $pounds = $data->{imperial_pounds} ) { # maybe null
        $kg += ( $pounds * 0.45359237 );
    }
	return sprintf '%.1f', $kg;
}

# removes square brackets (generates error); replaces left & right parentheses
# with mysql-escape strings; uses Regexp::Common qw(pattern):
=begin # patterns need to go at top - load only once or get warnings on >1st call
sub _mysql_escape_parens { # warnings: , etc
	my $str = shift;
	# create bespoke patterns:
	pattern name   => [ qw (parens left) ],
			create => quotemeta '(', # not used in ->subs() context
			subs   => sub {
				my $a = quotemeta '(';
				my $b = '[[.left-parenthesis.]]';
				$_[1] =~ s/$a/$b/g;
			};
	pattern name   => [ qw (parens right) ],
			create => quotemeta ')', # not used in ->subs() context
			subs   => sub {
				my $a = quotemeta ')';
				my $b = '[[.right-parenthesis.]]';
				$_[1] =~ s/$a/$b/g;
			};
	pattern name   => [ qw (local crop) ], # square brackets
			create => quotemeta '[]', # not used in ->subs() context
			subs   => sub {
				my $q = quotemeta '[]';
				$_[1] =~ s/[$q]//g; # same as s/[\[\]]//g !!
			};

    $str = $RE{local}{crop}->subs($str);   # warn $str;
	$str = $RE{parens}{left}->subs($str);  # warn $str;
	$str = $RE{parens}{right}->subs($str); # warn $str;
	return $str;
}
=cut

# removes square brackets (generates error); replaces left & right parentheses
# (+ other chars causing DBD::mysql::st execute errors) with mysql-escape strings
# eg ( => [[.right-parenthesis.]], | => [[.vertical-line.]]
sub mysql_escape_parens {
	my $str = shift;
	{ # remove square brackets:
		my $q = quotemeta '[]';
		$str =~ s/[$q]//g; # same as s/[\[\]]//g !!
	}

    # parentheses & error-inducing chars:
	$str =~ s/$_->[0]/[[.$_->[1].]]/g for (
        [ quotemeta ')' 	=>	qw(right-parenthesis) ],
        [ quotemeta '(' 	=> 	qw(left-parenthesis)  ],
        [ quotemeta '|'     =>  qw(vertical-line)     ],
        [ quotemeta '\\'    =>  qw(backslash)         ], # 5151652e095b [CARGO]
    ); # warn $str;

	return $str;
}

# compares 2 dates using DateTime->compare, returns '-1' if chronological order,
# 0 (empty) if dates the same, '1' if 1st date > 2nd date
sub check_chronological_order {
	my ($first_date, $last_date) = @_; # warn Dumper [$first_date->ymd, $last_date->ymd];

	return 0 unless $first_date && $last_date # also must be DT objects:
		&& ref $first_date eq 'DateTime' && ref $last_date eq 'DateTime';

    my $result = DateTime->compare($first_date, $last_date); # warn $result;
	return $result;
}

# turns hashref of multiple depth to single level hashref - will eliminate
# duplicate keys eg id
sub traverse_hash {
    my $deep_hashref = shift;

    my %h;
    Data::Traverse::traverse { $h{$a} = $b } $deep_hashref; # warn Dumper \%h;
    return \%h;
}

# 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]{1,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
}

sub get_yaml {
	my $args = shift;

    my @parts = @{ $args }{ qw(app_root yaml_dir filename) };
	my $src_file = sprintf '%s/config/settings/%s/%s.yml', @parts; # warn $src_file;

	if (-e $src_file) {
        my $yaml;
#        eval { # probably want to preserve & output any error
            $yaml = YAML::Tiny->read($src_file); # warn Dumper $yaml;
#        }; die @$ if @$;
        return wantarray() # eg my @yml = get_yaml($args)
			? $yaml
			: $yaml->[0];
    }
    return 0; # eg function not configured
}

sub reformat_address {
	my $addr = shift || return 0;

	my @lines = split /[\,\n]+/, $addr; # split on new-line, comma or both

	my @new = map { # doesn't deal with inconsistent use of comma between house number & street name
		# capitalise 1st letter of each word in @lines:
		join ' ', grep { s/(.*)/ucfirst( lc($1) )/e } split ' ', $_;
	} @lines;

	return join ', ', grep $_, @new; # reform with comma-space field delimiters
}

# 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;
}

sub delta_days {
    my ( $d0, $d1 ) = @_;

    my @d0 = split '-', $d0; # warn Dumper \@d0;
    my @d1 = split '-', $d1; # warn Dumper \@d1;

	my $result = Delta_Days( @d0, @d1 );
	return $result;
}

=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

# returns -1 for Sun 1-1-2010 -> Mon 2-1-2010 !!! use abs(x) to force positive
sub delta_business_days { # Date::Calc - How can I calculate the difference in days between dates, etc
    # using Date::Calendar method now - considers public hols:
    return _delta_workdays(@_);
=begin
    my ( $d0, $d1 ) = @_;

    my @d0 = split '-', $d0; # warn Dumper \@d0;
    my @d1 = split '-', $d1; # warn Dumper \@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 );
        }
    }

#	{ # check using Date::Calendar
		# my $delta = $calendar->delta_workdays(\@d0, \@d1, 1, 0);
        # warn Dumper [\@d0, \@d1, $result, $delta] if $result != $delta;
#	}

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

sub last_working_date {
    # pass DT object or create new as yesterday:
    my $o = shift; # optional
    # need to clone DT object (if supplied) to protect source from mutator methods:
    my $dt = $o ? $o->clone : time_now()->subtract(days => 1); # yesterday

    my $calendar = _get_calendar(); # warn Dumper $calendar;
    my $to_arrayref = sub { [ split '-', shift ] }; # returns arrayref of (yyyy, mm, dd)

    # subtract 1 day per weekend/holiday; is_full() returns true on non-work day:
    $dt->subtract(days => 1) while $calendar->is_full( &$to_arrayref($dt->ymd) );
    return $dt;
}

=begin # not used
sub _last_working_day { # receives value calculated in delta_last_working_day(), returns date in EU format
    my $delta = shift; # $delta always negative so use Add_Delta_Days:
    return join '-', reverse Add_Delta_Days( Today(), $delta );
}
=cut

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

	# !!! don't use CGI::Simple->escapeHTML - hangs in print_run in dev server:
    my $formatted = HTML::Escape::escape_html($string); # warn $formatted;
#    my $formatted = $cgi->escapeHTML($string); # warn $formatted;

    $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
		# warn $formatted;
    return $formatted;
}

sub clone {
    my $data = shift;
    my $cloned = Clone::clone($data);
    return $cloned;
}

sub deindent { # see Perl Cookbook 1.11 - Indenting Here Documents
	my $string = shift || return;
	$string =~ s/^[^\S\n]+//gm;
	return $string;
}

sub trim { # remove leading & trailing spaces
    my $str = shift // return; # ddp $str; # allows '0' but also empty string
    $str =~ s/^\s+//;
    $str =~ s/\s+$//;
    return $str;
}

sub user_agent {
    my $str = shift || return; # warn $str;
    my $ua = HTTP::BrowserDetect->new($str);
    return sprintf '%s %s-%s', map $ua->$_,
        qw(os_string browser_string public_version);
}

sub text_wrap {
    my ($width, $args) = @_; # col width & array(ref) of args to wrap() function

	$args->[-1] =~ s/^(\s+|\t)//; # remove leading spaces or tabs

    $Text::Wrap::columns = $width; # set col width
    return Text::Wrap::wrap(@$args);
}

sub this_year {
    return This_Year; # Date_Calc function
}

sub datetime_formatter {
    my $pattern = shift; # warn $pattern;
    return DateTime::Format::Strptime->new( pattern => $pattern );
}

sub time_now {
    my $args = shift || {}; # warn Dumper $args; # optional args for DT constructor
    $args->{time_zone} ||= 'Europe/London'; # in case time_zone submitted in $args
    return DateTime->now(%$args);
}

sub today { time_now(@_) } # just returns time_now() but uses UK time zone

sub date_and_time_now {
    my $args = shift || {}; # warn Dumper $args; # optional args for DT constructor

	my $now = time_now($args);
	return join ' ', $now->dmy, $now->hms;
}

sub time_now_hires {
    my $args = shift || {}; # warn Dumper $args; # optional args for DT constructor
    $args->{time_zone} ||= 'Europe/London'; # in case time_zone submitted in $args
    return DateTime::HiRes->now(%$args);
}

# 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 ] };
}

sub _delta_workdays { # using Date::Calendar (considers public hols)
    my ( $d0, $d1 ) = @_;

    my @d0 = split '-', $d0; # warn Dumper \@d0;
    my @d1 = split '-', $d1; # warn Dumper \@d1;

    # use date-1, date-2, flags 1, 0 for equivalence to Date::Calc result
    my $calendar = _get_calendar();
	my $delta = $calendar->delta_workdays(\@d0, \@d1, 1, 0); # flags 1 & 0
    return $delta;
}

=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

sub _get_calendar {
    return $_CACHE_{calendar} if $_CACHE_{calendar};

    my $profile = $Profiles->{GB}; # warn Dumper $profile; # hashref of UK holiday dates
        # $profile->{HollyDay} = '2/Mon/Feb'; # ficticous holiday (eg 2nd Mon in Feb) to test
    my $calendar = Date::Calendar->new($profile); # only happens once at server start
    $_CACHE_{calendar} = $calendar; # to return cache'd Date::Calendar object

=begin # check dates - Easter Sunday calculated in Date::Calc::PP::DateCalc_easter_sunday():
warn $calendar->is_full($_) for (
    [2013,1,1],   # NYD
    [2013,3,29],  # Easter Fri
    [2013,4,1],   # Easter Mon
    [2013,5,6],   # May Day
    [2013,5,27],  # Spring Bank
    [2013,8,26],  # Summer Bank
    [2013,12,25], # Xmas
    [2013,12,26], # Boxing Day

    [2010,12,25], # Xmas - Sat
    [2010,12,26], # Boxing Day - Sun
    [2010,12,27], # Mon - should be holiday
    [2010,12,28], # Tues - should be holiday
    [2010,12,29], # Weds - should not be holiday

    [2017,5,1],   # should be holiday but incorrectly assigned to 8th in 2017:
    [2017,5,8],   # is 2017 May Day holiday according to Date::Calendar::Profiles::GB_Early_May()
                  # "May bank holiday is the first Monday after May 1st"
);
=cut
    return $calendar;
}

1;
