######################################################################
#                                                                    #
# File name: chglnk_upload.pl							   #
#                                                                    #
# Purpose: Extends Upload Web Server to handle the uploading of      #
# linkage_table data provided by the user.          			   #
#                                                                    #
# Maintained by Hong Xu <hxu@chg.duhs.duke.edu>				   # 
# Center for Human Genetics Bioinformatics Core          		   #
# Duke University Medical Center                                     #
#                                                                    #
# You may distribute this module under the same terms as perl itself #
#                                                                    #
#                                                                    #
######################################################################

#!/usr/local/bin/perl -w
package Upload;
 
use strict;
use CGI;
use DBI;
use MIME::Lite;
use Spreadsheet::WriteExcel;
use Spreadsheet::ParseExcel;

my $q = CGI->new();
my $FNM = $q->upload('upload_file');
my $EML = $q->param('email');

print $q->header;

if ($EML ne "") {
  unless ($EML =~ /.+\@.+\..+/){
    print STDERR "Invalid email address.\n";
    msg("INVALID_EMAIL_ADDRESS");
    exit;
  }  
} else {
  msg("MISSING_EMAIL_ADDRESS");
  exit;
}
 

# copy data to temp file
my $tmpdir = $ENV{TMPDIR} || $ENV{TMP} || '/tmp';
my ($tmpfile, $outfile);

my $rsltnm;
if ($FNM) {
  print STDERR ("Copy LNK upload data to tmp file!\n");
  $tmpfile = "$tmpdir/upllnk_$$.xls";
  $outfile = "$tmpdir/lnkrslt_$$.xls";
  open (OUTFILE,">$tmpfile") or print STDERR ("Can't open temp file: $!\n");
  while (<$FNM>) {
    print OUTFILE $_;
  }
  close(OUTFILE);
  $FNM =~ m/^.*[\\\/](.*)/;
  $rsltnm = $1;
}
else {
  print STDERR "No data received!\n";
  msg("NO DATA received!");
  exit;
}

# set database connection
my $hostname = 'localhost';
my $dbnm = 'homo_sapiens_core_19_34a';
my $dbpt = '3308';
my $dsn = "DBI:mysql:database=$dbnm;host=$hostname;port=$dbpt";
my $dbh = DBI->connect($dsn, "user", "pwd",
   { RaiseError => 1, AutoCommit => 1 });   

# prepare output Excel file
my $workbook  = Spreadsheet::WriteExcel->new("$outfile");
my $sp_rslt = $workbook->addworksheet("Upload_result");
my $header = $workbook->addformat();
$header->set_font('Arial');
$header->set_bold();
$header->set_size(12);
my @aHd = ('Study', 'Analysis', 'Link_point', 'Score', 'Upload_info');
$sp_rslt->write(0, 0, \@aHd, $header);
my $iWrw = 1;
   
# open Excel file for upload
my $iRw = 1;
my $oExcel = new Spreadsheet::ParseExcel;
my $oBook = $oExcel->Parse($tmpfile);
my $oWkS = $oBook->{Worksheet}[0];

# read in header info:
# Study,anlysis,link_point,score,chr_name,chr_start,chr_end,link_type
my $head = fetchExcelRow($oWkS, 0, $oWkS->{MaxCol});
my @ahd = ();
my $iMC = 0;
foreach my $sFld (@{$head}) {
  last if ($sFld !~ m/\S+/);
  push @ahd, $sFld;
  $iMC++;
}
$iMC--;

while ( my $aRw = fetchExcelRow($oWkS, $iRw, $iMC) ) {

  print STDERR "$iRw	$iMC\n";
  my $chkcode = checkData($aRw);

  if ( $chkcode == 2 ) {
    # wrong chromosome name
    $sp_rslt->write($iWrw, 0, [ $aRw->[0],$aRw->[1],$aRw->[2],$aRw->[3],'Upload fail: Wrong chromosome name' ]);
    $iWrw++;
    $iRw++;
    next;
  }
  elsif ( $chkcode == 4 ) {
    # chromosome location out of range
    $sp_rslt->write($iWrw, 0, [ $aRw->[0],$aRw->[1],$aRw->[2],$aRw->[3],'Upload fail: chromosome location out of range' ]);
    $iWrw++;
    $iRw++;
    next;
  }
  elsif ( $chkcode == 5 ) {
    # chromosome start should be smaller than end
    ($aRw->[5], $aRw->[6]) = ($aRw->[6], $aRw->[5]);
  }
  
  my $upl = upload($aRw);
  if ($upl < 0) {
    $sp_rslt->write($iWrw, 0, [ $aRw->[0],$aRw->[1],$aRw->[2],$aRw->[3],'Upload fail: database problem' ]);
    $iWrw++;
  }
  else {
    $sp_rslt->write($iWrw, 0, [ $aRw->[0],$aRw->[1],$aRw->[2],$aRw->[3],'Upload succeed' ]);
    $iWrw++;
  }
  $iRw++;
}
    
msg("\nUpload result is sending to your email!");

$dbh->disconnect();

# email upload result
$workbook->close();
my $from_address = 'lnkupload@duke.edu';
my $subject = 'Linkage data upload result';
my $mime_type = 'TEXT';
my $message_body = "This is the machine generated email. Please do not reply!\n\n" .
  'Here attached the result for uploading data into linkage table.' . "\n";

# Create the initial text of the message
my $mime_msg = MIME::Lite->new(
   From => $from_address,
   To   => $EML,
   Subject => $subject,
   Type => $mime_type,
   Data => $message_body
   )
   or die "Error creating MIME body: $!\n";

my $recommended_filename = 'rslt_' . $rsltnm;

# Attach the output file
$mime_msg->attach(
   Type => 'application/zip',
   Path => $outfile,
   Filename => $recommended_filename
   )
  or die "Error attaching test file: $!\n";
$mime_msg->send();
  
print STDERR ("Result file has been sent to $EML!\n");


##########################################################################

sub checkData {
  my $data = shift;
  my $chrl = getChrLength($data->[4]);
  unless ($chrl) {
    return 2; # wrong chromosome name
  }
  if ($data->[5] < 0 || $data->[6] < 0 || $data->[5] > $chrl || $data->[6] > $chrl) {
    return 4; # chromosome location out of range
  }
  if ($data->[5] > $data->[6]) {
    return 5;
  }
}

sub upload {
  my $d = shift;
  
  my $sql = "insert into linkage (study,analysis,link_point,score,chr_name,chr_start,chr_end,link_type) values ('" .
    $d->[0] . "', '" . $d->[1] . "', '" . $d->[2] . "', " . $d->[3] . ", '" . $d->[4] . "', " . $d->[5] . ", " .
    $d->[6];
  if ($d->[7] eq 'dot') {
    $sql .= ", 'dot')";
  }
  else {
    $sql .= ")";
  }
  return -1 unless $dbh->do($sql);
  return 0;
}


 
##########################################################################
sub msg {
  my $code = shift;
  print $code,"\n";
}

sub fetchExcelRow
{
    my ($ioWkS, $iR, $iiMC) = @_;
    my($iC, $ioWkC);
    # test the the MinCol value
    $ioWkC = $ioWkS->{Cells}[$iR][$ioWkS->{MinCol}];
    if (!$ioWkC) {
        return;
    }
    elsif ( !($ioWkC->Value) || ($ioWkC->Value !~ m/\S+/) ) {
        return;
    }
    else {
        my @arow = ();
        for(my $iC = $ioWkS->{MinCol}; $iC <= $iiMC; $iC++) {
            $ioWkC = $ioWkS->{Cells}[$iR][$iC];
            push @arow, $ioWkC->Value;
        }
        return \@arow;
    }
}

sub getChrLength {
  my $chrnm = shift;
  my $sthchr = $dbh->prepare(q{select length from chromosome where name = ?});
  $sthchr->execute($chrnm);
  my $chrlength;
  $sthchr->bind_col(1, \$chrlength);
  $sthchr->fetch;
  return $chrlength;
}