#!/usr/bin/perl -Tw
use strict;
use CGI qw(:all delete_all escapeHTML);
$|=1;

######################################################################
# Ensure all fatals go to browser during debugging and set-up.       #
# This must be comment out on production code for security.          #
######################################################################
BEGIN {
    $|=1;
    print "Content-type: text/html\n\n";
    use CGI::Carp('fatalsToBrowser');
}

######################################################################
# Untaint the path & Use CGI.pm.                                     #
######################################################################
$ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin:/usr/local/sbin";

######################################################################
# Create new CGI.                                                    #
######################################################################
my $cgi = new CGI;

######################################################################
# Untaint & Check the CGI.                                           #
######################################################################
my ($error,$line);

# Argument 1: $session contains the process id #######################
my $session = get_session_id();                                    # Combination of local time and process

# Argument 2: $query contains query sequence #########################
my @query_info = ();
my $query = "/tmp/query.$session";                                 # File containing the query sequence
my $query_box = $cgi->param("query_box");                                # Server box where the query was pasted
my $query_file = $cgi->upload("query_file");                             # Server upload file content containing the query

#######################################
# 1. Extraction of the query sequence #
#######################################

# If the user pasted the query in the query box... #
if ($query_box ne "") {
    # Read the query sequence #
    @query_info = split(/\n/, $query_box);
# If the user upload the query in a file... # 
} else {
    # Read the query sequence #
    while (<$query_file>) {
        chomp $_;
        push (@query_info, $_);
    }
}

########################################################
# 2. Checking if the query sequence is in FASTA format #
########################################################

# Get the query tag & sequence #
(my @query) = @{extract_sequences(\@query_info)};

# If more than 1 query was submitted... #
if (scalar (@query) != 2) {
    # Error message #
    $error = "The query sequence is not in FASTA format or more than 1 query is submitted.\n";
    # Erase temp files #
    unlink ($query);
    # Print error page #
    print_error_page($error);
    # Exit the CGI #
    exit 0;
}

################################
# 3. Saving the query sequence #
################################

# Open file or give error message and exit the CGI #
open (FILE, ">$query") or ($error = "ModLink+ encountered an error: Cannot create the file to write the query sequence ($query). Do please notify this error by sending an e-mail to the server administrator (ofornes\@imim.es). We will contact you once the error is solved. Thanks for your patience.\n" and unlink ($query) and print_error_page($error) and exit 0);
# Foreach line of the file... #
foreach $line (@query) {
    # Print the line #
    print FILE $line."\n";
}
close (FILE);

# Argument 5: $databases contains databases ##########################
my $databases = "";
# If defined job title # 
foreach my $database ($cgi->param("databases")) {
    if ($database =~ /1-7/) {
        $databases .= $database;
    }
}

# Argument 3: $extrapolation contains SCOP codes extrapolation choice 
my $extrapolation = "none";                                        # String containing the SCOP codes extrapolation choice
if ($cgi->param("expansion") eq "by family") {
    $extrapolation = "fa";
} elsif ($cgi->param("expansion") eq "by superfamily") {
    $extrapolation = "sf";
} elsif ($cgi->param("expansion") eq "by fold") {
    $extrapolation = "cf";
}

# Argument 4: $MK_hub contains cut-off limit on the acceptance of hubs
my $MK_hub = "";                                                   # Integer containining the cut-off limit on the acceptance of hubs
if ($cgi->param("hubs") =~ /(\d+)/) {
    $MK_hub = $1;
} else {
    $MK_hub = "none";
}

# Argument 5: $EVTE contains evalue threshold on extrapolation (EVTE)
my $EVTE = "";                                                     # Integer containing the EVTE
if ($cgi->param("evte") =~ /(\d+)/) {
    $EVTE = $1;
} else {
    $EVTE = 1e-12;
}

# Argument 6: $EVTH contains evalue threshold on sequence homologs (EVTH)
my $EVTH = "";                                                     # Integer containing the EVTH
if ($cgi->param("evth") =~ /(\d+)/) {
    $EVTH = $1;
} else {
    $EVTH = 1e-70;
}

# Argument 7: $interactor contains query sequence ###################
my @interactors_info = ();
my $interactor = "/tmp/interactor.$session";                       # File containing the interactor sequences
my $interactor_num = $cgi->param("interactor_num");                # Integer containing the number of interactor sequences
my $interactor_box = $cgi->param("interactor_box");                # Server box where the interactors were pasted
my $interactor_file = $cgi->upload("interactor_file");             # Server upload file content containing the interactors

if ($interactor_box ne "" and $interactor_file ne "") {

    #############################################
    # 1. Extraction of the interactor sequences #
    #############################################

    # If the user pasted the interactors in the interactor box... #
    if ($interactor_box ne "") {
        # Read the interactor sequences #
        @interactors_info = split(/\n/, $interactor_box);
        # If the user upload the interactor in a file... #
    } else {
        # Read the interactor sequence #
        while (<$interactor_file>) {
            chomp $_;
            push (@interactors_info, $_);
        }
    }

    ###############################################################
    # 2. Checking if the interactor sequences are in FASTA format #
    ###############################################################

    # Get the interactor tags & sequences #
    (my @interactors) = @{extract_sequences(\@interactors_info)};

    # If more than 1 query was submitted... #
    if (scalar (@interactors) != ($interactor_num*2)) {
        # Error message #
        $error = "The interactor sequences are not in FASTA format or number of interactors submited does not correspond with the number you selected.\n";
        # Erase temp files #
        unlink ($query);
        unlink ($interactor);
        # Print error page #
        print_error_page($error);
        # Exit the CGI #
        exit 0;
    }

    ######################################
    # 3. Saving the interactor sequences #
    ######################################

    # Open file or give error message and exit the CGI #
    open (FILE, ">$query") or ($error = "ModLink+ encountered an error: Cannot create the file to write the interactor sequences ($interactor). Do please notify this error by sending an e-mail to the server administrator (ofornes\@imim.es). We will contact you once the error is solved. Thanks for your patience.\n" and unlink ($query) and unlink ($interactor) and print_error_page($error) and exit 0);
    foreach $line (@interactors) {
        # Print the line #
        print FILE $line."\n";
    }
    close (FILE);
# Not interactors submited #
} else {
    $interactor = "none";
}

1;

# Sub-routines from here ##########################################################

sub print_error_page {
######################################################################
# This function prints the error html head and body (error message   #
# every single place where enters this function).                    #
######################################################################

# Input #
my $error = $_[0];

# Print the errors page #
print       start_html('-title'  => "Secrets of the Pyramids",
                       '-author' => 'ofornes@imim.es',
                       '-base'   => "true",
                       '-target' => "_blank",
                       '-style'  => { '-src'  => "/styles/modlink.css" },
                       '-script' => { '-type' => 'JavaScript',
                                      '-src'  => "/javascript/modlink.js" }),
                table({'-border' => "0", '-cellspacing' => 0},
                   Tr({'-background' => "blue"},
                   td({'-class'  => "banner"},
                      [print_server_title_and_logos()]))),
                   h2("Request not processed"),
               strong($error),
             end_html();

sub print_server_title_and_logos {

      table({'-border' => "0", '-cellspacing' => 10},
         Tr(
         td({'-class'  => "program_name"},
            ["ModLink+<br />".print_server_options()]),
         td({'-class'  => "grib",
             '-align'  => "right"},
             img{src => "/img/grib_logo.gif"}),
         td({'-class'  => "sbi",
             '-align'  => "right",
             '-valign' => "center"},
             img  {src => "/img/sbi_logo.gif"})));
}

sub print_server_options {

      table({'-border' => "0", '-cellspacing' => 0},
         Tr({'-valign' => "bottom"},
         td({'-class'  => "options",
             '-onMouseOut'  => "style.color='white';",
             '-onMouseOver' => "style.cursor='pointer';style.color='black';"},
             ["<a onClick=\"index.html\">Home</a>"]),
         td({'-class'  => "options",
             '-onMouseOver' => "style.cursor='pointer';style.color='black';",
             '-onMouseOut'  => "style.color='white';"},
            ["Recent Results"]),
         td({'-class'  => "options",
             '-onMouseOver' => "style.cursor='pointer';style.color='black';",
             '-onMouseOut' => "style.color='white';"},
            ["Help"])));
}
}

sub extract_sequences {
######################################################################
# This function goes through the sequence data extracting lines that #
# contains sequence or tags.                                         #
######################################################################
my ($line);
# Initialize #
my $sequence = "";
my @sequences = ();
# Input #
my @extracted_data = @{$_[0]};

# Foreach line of sequence... #
foreach $line (@extracted_data) {
    chomp $line;
    # Skip lines containing info... #
    if ($line =~ /^\s*$/) {
        next;
    } elsif ($line =~ /^\s*#/) {
        next;
    # Get the line with tag identifier #
    } elsif ($line =~ /^>/) {
        push (@sequences, $line);
    # Get the line with sequence and join it to the main sequence #
    } else {
        # If previous item saved is a tag identifier... #
        if ($sequences[scalar (@sequences) -1] =~ /^>/) {
            # Push the line with sequence to @sequences #
            push (@sequences, $line);
        # If previous item saved is a sequence... #
        } else {
            # Join the sequence to the main sequence #
            if (defined $sequences[scalar (@sequences) -1]) {
                $sequences[scalar (@sequences) -1] .= $line;
            } else {
                push (@sequences, $line);
            }
        }
    }
}

# Foreach position in @sequences #
for (my $pos = 0; $pos < scalar (@sequences); $pos++) {
    # If item saved is sequence... #
    if (!($sequences[$pos] =~ /^>/)) {
        # Clean up the sequence #
        $sequences[$pos] =~ s/\n//mg;    # make one line
        $sequences[$pos] =~ s/\r//mg;    # make one line
        $sequences[$pos] =~ s/\W+//g;    # eliminate non-word char
        $sequences[$pos] =~ s/_+//g;     # eliminate underscore, since not covered by \W
        $sequences[$pos] =~ s/\d+//g;    # eliminate numbers
        $sequences[$pos] =~ s/\*//;      # eliminate *'s
        $sequences[$pos] =~ s/\s+//g;    # eliminate spaces
        $sequences[$pos] =~ tr/a-z/A-Z/; # convert to uppercase
    }
}

return (\@sequences);
}

sub get_session_id {
######################################################################
# Defines self session id.                                                        #
######################################################################
    require Digest::MD5;
    Digest::MD5::md5_hex(Digest::MD5::md5_hex(time().{}.rand().$$));
}