• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/env perl

# updates ODS data files, downloads from cfh_downloads location, extracts to
# temp location & moves files to data files dir. Inactivates retired GP's.
# -t flag for outputting intent only (doesn't update db table)

use strict;
use warnings;
use feature 'say';

#-------------------------------------------------------------------------------
my $tbl = 'hilis4.referrers'; # 'lims_test.referrers'
#-------------------------------------------------------------------------------

use lib (
    '/home/raj/perl5/lib/perl5',
    '/home/raj/apps/HILIS4/lib',
);

use IO::All;
use Text::CSV;
use Path::Tiny;
use File::Copy;
use Getopt::Std;
use Config::Tiny;
use Data::Printer;
use File::Basename;
use LWP::UserAgent;
use Archive::Extract;
use FindBin qw($Bin);
use Digest::MD5 qw(md5_hex);
use LIMS::Local::ScriptHelpers;

getopts('t'); # testing
our($opt_t); # warn $opt_t; exit;

my $JUST_TESTING = $opt_t || 0; # outputs update intent, doesn't do it

my $tools = LIMS::Local::ScriptHelpers->new();
my $dbix  = $tools->dbix(); # for GP updates

# define paths & filenames:
my $app_dir  = path($tools->path_to_app_root)->realpath;
my $data_dir = $app_dir  . '/src/data';
my $temp_dir = $data_dir . '/tmp_files';
my $script   = $tools->script_filename;

# filename for temp file:
my $temp_zip_file = $temp_dir . '/temp.zip';

my $cfg = Config::Tiny->read($app_dir . '/config/settings/global.txt'); # p $cfg; exit;
my $url = $cfg->{_}->{cfh_downloads}; # p $url;

my $ua = LWP::UserAgent->new;

my @files = map $_->filename,
    grep $_->filename =~ /\.csv$/, io($data_dir)->all_files; # p @files;

my $response;

#=begin # to just update GP's
FILE:
for my $file (@files) {
    # skip local data files which don't exist on remote site:
    next FILE if grep $file =~ /^$_/, qw(default specialities);
    # only need to capture filename part (normally filename, path, suffix):
    my $filename = fileparse($file, '.csv'); # p $filename; next FILE;

    my $old_csv_file = "$data_dir/${filename}.csv"; # p $old_csv_file;
    my $new_csv_file = "$temp_dir/${filename}.csv"; # p $new_csv_file;

    my $ods_file = sprintf '%s/%s.zip', $url, $filename; # p $ods_file; # next;
    $ods_file =~ s/niorg/NIORG/; # typical ODS stupidity !!

    # download file to temp dir:
    eval { # get the file or give up after 15secs:
        local $SIG{ALRM} = sub {
            die 'LWP::UserAgent timeout' . "\n"; # NB \n required
        };
        alarm 15;
        $response = $ua->get( $ods_file, ':content_file' => $temp_zip_file );
        alarm 0;
    };
    $response->is_success
        or error($filename, $response->status_line) and next FILE;

    # extract file:
    my $archive = Archive::Extract->new(archive => $temp_zip_file);
    $archive->extract(to => $temp_dir)
        or error($filename, $archive->error) and next FILE;

    # backup old data file if checksums differ & move new one into place:
    my $md5_old_file = md5_hex( io($old_csv_file)->all ); # p $md5_old_file;
    my $md5_new_file = md5_hex( io($new_csv_file)->all ); # p $md5_new_file;
    if ( $md5_old_file ne $md5_new_file ) { # p $filename; warn 'here';
        ( my $backup_filename = $old_csv_file ) =~ s/csv$/old/;
        io($old_csv_file)->rename($backup_filename);
    }
    move( $new_csv_file, $old_csv_file ) or error($filename, $!);
    # so data file mtime never >1 month:
    ( my $timestamp = $tools->time_now ) =~ s/T/ /;
    system('/usr/bin/touch', "-d $timestamp", $old_csv_file); # old is now new
}
#=cut

# inactivate retired/closed GP's:
{
    my $src_file  = $data_dir . '/egpcur.csv';
    my $io = new IO::File;
    open( $io, '<', $src_file ) || die $!;

    my $opt = { binary => 1 }; # recommended to set true
    my $csv = Text::CSV->new($opt); # p $csv; exit;

    my $total = my $updated = 0;
    while ( my $ref = $csv->getline($io) ) { # p $ref; # aref
        my ($code, $status) = map $ref->[$_], (0, 12); # p $code; p $status;
        next if $status eq 'A'; # active, B = retired, C = closed (?), P = proposed
        $total++;
        # do we have an active referrer matching national_code?
        $dbix->select($tbl, 1,
            { national_code => $code, active => 'yes' } )->list || next;
        $updated++;
        if ($JUST_TESTING) {
            say "will set $code to inactive ($status)";
            # say qq!"$code",! if $status eq 'B'; # for sql query IN (...)
        }
        else {
            $dbix->update($tbl, { active => 'no' }, { national_code => $code });
            say "$script updated $code status to inactive ($status)";
        }
    }
    say "inactivated $updated HILIS referrer table GPs of total $total "
        . 'inactive national GPs' if $JUST_TESTING;
}

sub error { warn join ': ', @_ }