• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Controller::Roles::ULISA;

use Moose::Role;
use Data::Dumper;
use IO::All;

use XML::Simple qw(:strict); # need to specify ForceArray & KeyAttr if using :strict here
use LIMS::Local::ScriptHelpers; # ftp_file() method - not needed if using local dir

has xs_options => ( is => 'ro', isa => 'HashRef', lazy_build => 1 );
has ulisa_ref  => ( is => 'rw', isa => 'Int' );
has script_helpers => ( is => 'ro', isa => 'LIMS::Local::ScriptHelpers',
    lazy_build => 1 ); # provides ftp_file() method - don't need if using local dir

sub send_xml {
    my ($self, $data) = @_; # warn Dumper $data;

    $self->ulisa_ref($data->{request}->{id}); # request.id

    # $self->_example_data(); # uncomment to dump data structure for example xml

    my $xs = XML::Simple->new();

    # options for XMLout (needs array or hash):
    my %xs_opts = %{ $self->xs_options }; # warn Dumper \%xs_opts;

    # manipulate $data into hashref format expected by XMLout:
    my $ref = $self->_format($data); # warn Dumper $ref;

    # enclose xml in outer <add> block; add ulisa 'version' inline:
    my $input = { add => $ref, version => 2 };
   	my $xml_out = $xs->XMLout( $input, %xs_opts ); # warn Dumper $xml_out;

    my $rtn = $self->_dispatch($xml_out);
    return $rtn;
}

sub _dispatch {
    my ($self, $xml) = @_; # XMLout string

    my $req_id = $self->ulisa_ref; # warn $req_id;
    my $tools  = $self->script_helpers(); # warn Dumper $tools;
    my $cfg    = $self->cfg('settings');  # warn Dumper $cfg;

    my $filename = sprintf '%s.xml', $req_id;
    my $src_path = '/tmp/' . $filename;

    # $xml > io($src_path); # gives 'Useless use of numeric gt (>) in void context'
    # warning on 1st call to Local::Labels after server startup; alt. syntax:
    io($src_path)->print($xml);

    my %params = (
        remote_filename => $filename,
        local_filename  => $src_path,

        passive_mode => 1, # otherwise get 'FTP error - STOR command started' with CoreFTP
        server_addr  => $cfg->{dako_link_addr},
        username     => $cfg->{dako_link_user},
        password     => $cfg->{dako_link_pwd},
    ); # warn Dumper \%params;

    # ftp file (returns str on failure, undef on success):
    my $rtn = $tools->ftp_file(\%params);

    if ($rtn) { # warn Dumper $rtn;
       return $rtn;
    }
    else {
        io($src_path)->unlink;
        return 0;
    }
}

sub _format { # returns hashref:
    my ($self, $data) = @_;

    my $request  = $data->{request};
    my $patient  = $data->{patient};
    my $lab_test = $data->{lab_test};

    my $now = LIMS::Local::Utils::time_now->epoch; # warn $now;

    my $lab_number = join '/',
        $request->{request_number}, $request->{year} - 2000;

=begin # set XMLout option "NoAttr => 0"
data values as arrayref produces nested output:
eg case => { caseid => [ $caseid ] } produces:
<case>
    <caseid>1234</caseid>
</case>

data values as string produces inline:
eg case => { caseid => $caseid } produces <case caseid='1234'>
=cut

    my @slides;
    for my $ref (@$lab_test) { # warn Dumper $ref;
        # create unique slide ID from request.id, test.id & epoch (max 32 chars):
        my $slide_id = sprintf 'R%sT%sE%s',
            $request->{id}, $ref->{test_id}, $now;

        push @slides, {
            slideid    => [ $slide_id ],         # nested
            protocol   => [ $ref->{test_name} ], # nested
            slidetype  => [ 2 ], # IHC           # nested
		};
    }

    my %slides = (
        caseid => $lab_number,                   # inline
        slide  => \@slides,
    );

    my %case = (
        requestid => [ $request->{id} ],         # nested
        firstname => [ $patient->{first_name} ], # nested
        lastname  => [ $patient->{last_name} ],  # nested
        caseid    => $lab_number,                # inline
    );

    my %h = ( # hash data structure for input to XMLout
        case   => \%case,
        sildes => \%slides,
    ); # warn Dumper \%h;
    return \%h;
}

sub _build_xs_options {
    my %opts = (
        SuppressEmpty => 0, # ? only works for xml_in
        RootName      => 'ulisa',
        XMLDecl       => q!<?xml version="1.0" encoding="UTF-8"?>!,
        KeyAttr       => [],
        NoAttr        => 0, # gives inline (scalar) AND nested (arrayref) attributes
    );
    return \%opts;
}

sub _build_script_helpers { LIMS::Local::ScriptHelpers->new }

sub _example_data {
    my $self = shift;

    my $xs = XML::Simple->new();
    my %opts = %{ $self->xs_options }; # warn Dumper $opts;

    my $data; $data .= $_ for <DATA>;  warn $data;

    my $href = XMLin($data, ForceArray => 1, KeyAttr => []); warn Dumper $href;
    my $xml  = $xs->XMLout( $href, %opts );  warn Dumper $xml;
}

1;

__DATA__
<add>
    <case caseid="H12345678">
        <firstname>Norbert</firstname>
        <lastname>Colon</lastname>
    </case>
    <slides caseid="H12345678">
        <slide>
            <slideid>87</slideid>
            <slidetype>2</slidetype>
            <protocol>CD20</protocol>
        </slide>
        <slide>
            <slideid>88</slideid>
            <slidetype>2</slidetype>
            <protocol>ki-67</protocol>
        </slide>
    </slides>
</add>