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$1<\/sup>\/$2/ig; # 10/9/l; 10/6/kg; etc $formatted =~ s/10\^(\d)/10$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;