• Files
• Commits
• Log
• Graph
• Stats

package Local::Utils;

use 5.26.0;

use Clone;
use DateTime;
use Data::Page;
use List::Util;
use Crypt::CBC;
use Date::Parse;
use Email::Valid;
use Digest::SHA1;
use Git::Wrapper;
use HTML::Escape;
use List::Compare;
use Array::Compare;
use Time::Moment 0.19;
use HTTP::BrowserDetect;
use Lingua::EN::Inflect 'PL';
use DateTime::Format::Strptime;
use DateTime::Format::DateParse;
use Scalar::Util 'looks_like_number';
use DateTime::Format::Human::Duration;
use Data::Printer alias => 'p', use_prototypes => 0;

use Date::Calc qw(Delta_Days);
use Date::Calendar;
use Date::Calendar::Profiles qw( $Profiles ); # warn Dumper $Profiles->{GB};
my %_CACHE_; # for Date::Calendar object

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

    my $formatted = HTML::Escape::escape_html($string); # p $formatted;

    $formatted =~ s/(\d)\/ul/$1\/µ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
		# p $formatted;
    return $formatted;
}

sub pluralise { PL(@_) } # string, num; using Lingua::EN::Inflect PL

sub clone { Clone::clone(shift) }

sub is_valid_email { Email::Valid->address(@_) }

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

sub time_now {
    my $args = shift || {}; # p $args; # optional args for DT constructor
    $args->{time_zone} ||= 'Europe/London';
    # default format "yyyy-mm-dd hr:min:sec" if called as time_now() ie without ->function:
    $args->{formatter} ||= DateTime::Format::Strptime->new( pattern => '%F %T' );
    return DateTime->now(%$args);
}

sub today { time_now(@_) } # just returns time_now()

sub this_year { time_now(@_)->year }

sub delta_days { # Date_Calc method
    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;
}

sub long_date_to_time { Date::Parse::str2time($_[0]) }

# takes either DateTime object, or epoch seconds, returns human-readable
# duration to 2 significant units if over 1 month ago eg 2 weeks and 2 days,
# 1 year and 2 months, otherwise to 1 sig unit eg 4 days, 3 hours, etc
sub date_relative {
    my $t0 = shift; # p $t0; # DateTime object or epoch seconds

    my $dtf = DateTime::Format::Human::Duration->new();
    my $now = time_now();

    my $sig_units = 1;

    if ( Scalar::Util::looks_like_number($t0) ) {
        $t0 = DateTime->from_epoch(epoch => $t0); # p $ref;
    }
    # check we now have a DateTime object:
    die "unknown format of reference time $t0" unless ref $t0 eq 'DateTime';

    # boost sig units to 2 if > 1 day ago:
    $sig_units++ if $now->delta_days($t0)->delta_days > 1;
    return $dtf->format_duration_between($now, $t0, significant_units => $sig_units);
}

sub git_wrapper { Git::Wrapper->new($_[0]) } # expects full/path/to/repo

sub app_version { git_wrapper($_[0])->log } # in scalar context returns size of array

sub gitlog { # console output: git log --pretty=format:"%ad%n%B" --relative-date
    my $path = shift;

    my $git = git_wrapper($path);

    my @entries = $git->log({ raw => 0 }); # p \@entries; # raw => 1 = more detail

    my @log;
    for my $entry (@entries) {
        my $long_date = $entry->date;    # say $long_date; eg Wed Dec 28 14:11:03 2016 +0000
        my $message   = $entry->message; # say $message;
        # get epoch object from long_date, then get human-readable form:
        my $epoch    = long_date_to_time($long_date); # p $epoch;
        my $rel_date = date_relative($epoch); # p $rel_date;
        push @log, { rel_date => $rel_date, message => $message };
    } # p \@log;
    return \@log;
}

sub paginator {
    my ($total_entries, $entries_per_page, $current_page) = @_;
        # p [$total_entries, $entries_per_page, $current_page];
    my $page = Data::Page->new();
    $page->total_entries($total_entries);
    $page->entries_per_page($entries_per_page);
    $page->current_page($current_page);
    return $page;
}

sub math_sum { List::Util::sum(@_); }

sub encrypt { # Crypt::CBC
    my ($str, $key) = @_;
	# The new CBC::Encrypt defaults to -pbkdf => 'opensslv1' to preserve compatibility and warns
    # about that at the same time. Session::Storage::Secure can either pass -nodeprecate=>1 to
	# silent the warning, or pass -pbkdf => 'pbkdf2' to use stronger encryption key.
    my $cipher = Crypt::CBC->new({ key => $key, pbkdf => 'pbkdf2' }); # added pbkdf key to silence warning
    return $cipher->encrypt_hex($str);
}

sub decrypt { # Crypt::CBC
    my ($str, $key) = @_; # p [$str, $key];
    my $cipher = Crypt::CBC->new({ key => $key });
    return $cipher->decrypt_hex($str);
}

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

sub matches {
	my ($var,$const) = @_; # p [$var,$const];

	return ( looks_like_number($const) && looks_like_number($var) )
		? $var == $const
		: $var eq $const;
}

sub fileopen {
	my ($mode, $filename) = @_;
	my %d = (
		r   => '<',   # Read-only
		w   => '>',   # Write (truncate file, create new)
		a   => '>>',  # Append only
		rw  => '+<',  # Read/write (no truncate)
		rwt => '+>',  # Read/write (truncate file, create new)
		rwa => '+>>', # Read/write (append)
	);
	open my $fh, $d{$mode}, $filename
		or die "Could not open $filename with mode $mode: $!";
	return $fh;
}

sub compare_arrays {
    @_ == 2 && map { ref $_ eq 'ARRAY' } @_ or die "require 2 arrayrefs";
    return Array::Compare->new->compare(@_);
}

# get unique items from left-hand list, return unsorted:
sub get_unique_items_list_a {
	@_ == 2 && map { ref $_ eq 'ARRAY' } @_ or die "require 2 arrayrefs";
	return List::Compare->new('-u', @_)->get_Lonly; # alias for ->get_unique
}

# get unique items from right-hand list, return unsorted:
sub get_unique_items_list_b {
	@_ == 2 && map { ref $_ eq 'ARRAY' } @_ or die "require 2 arrayrefs";
	return List::Compare->new('-u', @_)->get_Ronly; # alias for ->get_complement
}

# get common items from bothd lists, return unsorted:
sub get_common_list_items {
	@_ == 2 && map { ref $_ eq 'ARRAY' } @_ or die "require 2 arrayrefs";
	return List::Compare->new('-u', @_)->get_intersection;
}

# get unique items from both lists, combine and return unsorted:
sub get_unique_items_both_lists {
	@_ == 2 && map { ref $_ eq 'ARRAY' } @_ or die "require 2 arrayrefs";
	return List::Compare->new('-u', @_)->get_symmetric_difference;  # ->get_LorRonly
}

# select random element from array(ref):
sub get_random_element {
	my $ary = shift;
	die "require arrayref" unless ref $ary eq 'ARRAY';
	return $ary->[rand @$ary];
}

# transforms DateTime object, or (recursive) hashref of keys with value(s) DateTime:
sub datetime_to_string {
    my $r = shift; # say ref $r;
	# return stringified if DT object:
	return "$r" if ref($r) =~ /^DateTime/;
	# return unless hashref:
    return unless ref($r) eq 'HASH';

    for my $key ( keys %$r ) {
        if ( ref($r->{$key}) eq 'HASH' ) { # recursive call for hashrefs
            datetime_to_string( $r->{$key} ); # p $r->{$key};
        }
        if ( ref($r->{$key}) =~ /^DateTime/ ) { # p $r->{$key};
            $r->{$key} = sprintf "%s", $r->{$key}; # quote to force to string
        }
    }
	return $r;
}

# accepts any date string recognised by Date::Parse, return DateTime object:
sub date_string_to_datetime {
    my $str = shift; # p $str;
    my $dt = DateTime::Format::DateParse->parse_datetime($str); # p $dt;
    return $dt;
}

sub last_working_date {
    # pass DT object or create new as yesterday:
    my $dt = shift || DateTime->today->subtract(days => 1); # yesterday

    my $calendar = date_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;
}

sub date_calendar {
    return $_CACHE_{calendar} if $_CACHE_{calendar}; # warn 'here';

    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
);
=cut
    return $calendar;
}

sub dump_query {
# might need to use Local::DB::_replace_omniholder if sql contains '??'
    my ($class, $sql, @bind) = @_; # p $class;

    # $class should be Local::DB or LIMS::Local::DBIxSimple object:
    die "first arg should be a class object able to provide a dbh (DBI::db) object"
        unless ref $class && $class->can('dbh'); # need to call ->quote()

    for my $val (@bind) { # replace each '?' with next element of array:
        $val = $class->dbh->quote($val) # quote anything other than numbers
        # $val = qq!"$val"! # quote anything other than numbers
            unless Scalar::Util::looks_like_number($val); # say $val;
        $sql =~ s/\Q?/$val/;
    }

=begin
    $sql =~ s/(FROM|WHERE|ORDER BY|GROUP BY)/\n$1/g;
    $sql =~ s/(LEFT OUTER|INNER)/\n\t$1/g;
    $sql =~ s/(\sAND\s)/\n\t$1/g;
=cut
    # replace all white-space (spaces, tabs, new-lines) with single space:
    $sql =~ s/\s+/ /g; # p $sql;
    # all queries have a SELECT ... FROM ...
    my ($cols, $remainder) = $sql =~ /SELECT (.*) FROM (.*)/;  # p $cols;
    # new-lines after comma in SELECT statement, unless inside brackets; doesn't
    # work for brackets-within-brackets eg LEFT(ref.name, .... LOCATE(' ', ....))
    $cols =~ s/(\,(?!\s?\?|[^(]+\)))(?!\n)/$1\n /g;      # p $cols;
    $remainder =~ s/(LEFT OUTER|INNER|\sAND\s)/\n  $1/g; # p $from;
    # build new query string:
    my $str = qq!SELECT\n  $cols\nFROM\n  $remainder!;
    $str =~ s/\b(WHERE|ORDER BY|GROUP BY|HAVING|LIMIT|OFFSET)\b/\n$1/g;
    $str .= ';' unless $str =~ /;$/; # p $str;

    my $lh_parens = "\Q(";
    my $rh_parens = "\Q)";
    $str =~ s/(OR $lh_parens)/\n\t$1/g;
    # $str =~ s/($lh_parens|$rh_parens)/\n\t$1/g; # also works OK
    # $str =~ s/(OR|AND)/\n\t$1/g; # doesn't really work

    my $divider = '#' . '-' x 80 . "\n";
    print "\n" . $divider . $str . "\n" . $divider;
}

1;