• Files
• Commits
• Log
• Graph
• Stats

#!/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;
use DateTime;

my $tools = LIMS::Local::ScriptHelpers->new();
my $dbix  = $tools->dbix();

my $src = '/home/raj/scripts/socket_logs/socket.out.2';

my @file = io($src)->chomp->slurp; # warn Dumper @file;

my $tbl = 'request_haematology';

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 request_id = ?!,
);
    
ROW:
for (@file) {
	my $data = parse_data($_); # warn Dumper $data;
    next ROW unless $data; # returns hashref or 0
    
    # get request ID from request_number & year:
    $dbix->query($SQL{request_id}, $data->{request_number}, $data->{year})
        ->into( my $request_id ); # warn $data->{request_id};
    next ROW unless $request_id; # in case lab number entry in wrong format
    
    # does request already have result:
    $dbix->query($SQL{get_status}, $request_id)->into(my $status);
    
    if ($status) { # exists - can only over-write if not already verified:
        next ROW if $status eq 'verified'; # can't overwite here (delete in app)
        $dbix->delete($tbl, { request_id => $request_id }); warn 'OVERWRITE';
    }
    # add request_id to $data & delete request_number & yr keys:
    $data->{request_id} = $request_id;
    delete $data->{$_} for qw(request_number year);
    # insert new data:
    $dbix->insert($tbl, $data);
}

=begin
our $data;

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";
=cut

=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

=begin
# flush after every write
$| = 1;
open my $fh, '>', 'socket.out' or die $!;
$fh->autoflush(1);

my $tools = LIMS::Local::ScriptHelpers->new();
my $dbix  = $tools->dbix();

while ( 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";

    # read in 1024 chunks:
	while ( $client_socket->read($data, 131) ) { # warn Dumper [ $now->datetime, $data ];
		# print $fh DateTime->now->datetime . "\n$data\n";
		print $fh $data . "\n";
		my ($yr, $request_number) = $data =~ /D1U\d{16}(\d{2})\-(\d{5})/;
		if ( $yr && $request_number ) {
			warn Dumper [2000 + $yr, $request_number];
		}
	}	
}

close $socket;
=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 zero padding
		([\d-]{8})       # req. no. - 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
	/x;
	
    unless ($labno && @params) {
        warn $data; # need to log with timestamp
        return 0;
    }

    # split $labno on '-':
    my ($yr, $request_number) = split '-', $labno;    
    return 0 unless $yr && $request_number; # warn Dumper [$yr, $request_number];
    
    # create hash of data:
	@h{@fields} = @params; # warn Dumper \%h;
    
    # add request_number & year:
    $h{request_number} = $request_number;
    $h{year} = $yr + 2000; # warn Dumper \%h;
	return \%h;
}