#!/usr/bin/perl
# http://www.perlfect.com/articles/sockets.shtml
BEGIN {
use FindBin qw($Bin); # warn 'BIN:'.$Bin;
# set lib paths for app:
use lib (
"$Bin/../lib",
'/home/raj/perl5/lib/perl5',
);
}
use strict;
use warnings;
use IO::All;
use IO::Socket;
use IO::Handle;
use LIMS::Local::ScriptHelpers;
use Data::Dumper;
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->use_path("$Bin/.."); # for ScriptHelpers to find correct path to app root
my $cfg = $tools->get_settings; # warn Dumper $cfg;
=begin # for testing with a datafile
my $src = '/home/raj/scripts/socket_logs/socket.out.2';
my @file = io($src)->chomp->slurp; # warn Dumper @file;
=cut
my $tbl = 'request_haematology';
my $log_file = "$Bin/../logs/lantronix.log";
my @fields = qw(
pda wbc wbc_f rbc rbc_f hb hb_f hct hct_f mcv mcv_f mch mch_f mchc mchc_f
plt plt_f lymph_percent lymph_percent_f mixed_percent mixed_percent_f
neutr_percent neutr_percent_f lymph lymph_f mixed mixed_f neutr neutr_f
);
my %SQL = (
# request_id => q!select id from requests where request_number = ? and year = ?!,
get_status => qq!select status from $tbl where lab_number = ?!,
);
# flush after every write
$| = 1;
open my $fh, '>>', $log_file or die $!;
$fh->autoflush(1);
#=begin # open a socket:
my $socket = IO::Socket::INET->new(
LocalHost => '163.160.171.164', # full IP address to accept external connections
LocalPort => 9001,
Proto => 'tcp',
Listen => 1,
ReuseAddr => 1
) or die "Could not create socket: $!\n";
our ($r); # output from lantronix box
while ( my $client_socket = $socket->accept ) {
# my $peer_addr = $client_socket->peerhost();
# my $peer_port = $client_socket->peerport();
# print "Accepted new client connection from $peer_addr, $peer_port\n";
READ: # read in 131-char chunks:
while ( $client_socket->read($r, 131) ) { # warn Dumper $r;
# print $fh DateTime->now->datetime . "\n$r\n";
my $data = parse_data($r); # warn Dumper $data; # returns hashref or 0
if ($data) {
my $ok = process_data($data); # method returns 1 on success
next READ if $ok;
}
do_log($r); # no $data or process_data() returns false
}
}
close $socket;
#=cut
=begin # for testing with datafile
ROW:
for (@file) {
my $data = parse_data($_); # warn Dumper $data;
next ROW unless $data; # returns hashref or 0
process_data($data);
}
=cut
sub parse_data {
my $data = shift; # warn length $data;
my %h = (); # data hash to return
my ($labno, @params) = $data =~ /
D1U\d{16} # year, month, day + sample ID padding (8 zeros)
([\d-]{8}) # sample ID = 8 char, right-aligned eg 000012_1, 0012_100, 12_10000, etc
(\w{6}) # PDA info
\d # RDW select || reserve
([\d*]{4})(\d) # wbc + flag
([\d*]{4})(\d) # rbc + flag
([\d*]{4})(\d) # hb + flag
([\d*]{4})(\d) # hct + flag
([\d*]{4})(\d) # mcv + flag
([\d*]{4})(\d) # mch + flag
([\d*]{4})(\d) # mchc + flag
([\d*]{4})(\d) # plt + flag
([\d*]{4})(\d) # lymph (%) + flag
([\d*]{4})(\d) # mixed (%) + flag
([\d*]{4})(\d) # neutr (%) + flag
([\d*]{4})(\d) # lymph (#) + flag
([\d*]{4})(\d) # mixed (#) + flag
([\d*]{4})(\d) # neutr (#) + flag
# .*{5} # rdw - don't need
# .*{5} # pdw - don't need
# .*{5} # mpv - don't need
# .*{5} # p-lrc - don't need
/xo;
return 0 unless $labno && @params;
# split $labno on '-' (if exists):
my ($yr, $request_number) = split '-', $labno;
# check have both, and int $yr = 2-digits (eg 00012):
return 0 unless $yr && $request_number && length(int $yr) == 2; # warn Dumper [$yr, $request_number];
# create hash of data:
@h{@fields} = @params; # warn Dumper \%h;
# add lab number (yy_nnnnn format):
$h{lab_number} = sprintf '%02d_%05d', $yr, $request_number;
return \%h;
}
sub process_data {
my $data = shift;
my $lab_number = $data->{lab_number};
my $dbix = get_dbix(); # get new dbix object
# does request already have result:
$dbix->query($SQL{get_status}, $lab_number)->into(my $status);
if ($status) { # exists - can only over-write if not already verified:
return 0 if $status eq 'verified'; # can't overwite here (delete in app)
$dbix->delete($tbl, { lab_number => $lab_number }); # warn 'OVERWRITE';
}
# insert new data:
$dbix->insert($tbl, $data);
return 1;
}
sub do_log { # log with timestamp:
my $data = shift;
print $fh $tools->time_now->datetime . "\n$data\n";
# leading char should be '02H' hex char; ord(02H) = 2, so chr(2) should re-encode for use in var:
my $stx = chr(2); # warn Dumper $stx; - will be undef
alert_admin($data) if $data !~ /^${stx}D1U/; # indicates possible data stream corruption
}
# return a new dbix object for each dataset - not using ScriptHelpers::get_dbix()
# to avoid cacheing db connection and MySQL timeout after >8hrs idle:
sub get_dbix {
my $uid = $cfg->{db_user_id};
my $pwd = $cfg->{db_password};
my $db = $cfg->{production_db};
my $dsn = "dbi:mysql:$db";
my $dbix = DBIx::Simple->connect($dsn, $uid, $pwd, { RaiseError => 1 });
return $dbix;
}
sub alert_admin {
my $data = shift;
my $msg = join "\n", 'LANTRONIX POSSIBLE DATA CORRUPTION:', $data;
$tools->mail_admin({ script => io($0)->filename, msg => $msg });
}
__END__
=begin
Now the socket is ready to receive incoming connections. To wait for a connection,
we use the accept() method which will return a new socket through which we can
communicate with the calling program. Information exchange is achieved by
reading/writing on the new socket. The socket can be treated like a regular
filehandle.
=cut
=begin
while (1) { # permanent
# waiting for new client connection.
my $client_socket = $socket->accept();
# my $peer_address = $client_socket->peerhost();
# my $peer_port = $client_socket->peerport();
# print "Accepted New Client Connection From : $peer_address, $peer_port\n";
# my $data = <$client_socket>;
# we can also read from socket through recv() in IO::Socket::INET
$client_socket->read($data, 1024);
print $data;
}
=cut
