#!/usr/local/bin/perl
##############################################################################
# Shell execution of ms-getseq.exe                                           #
##############################################################################
# COPYRIGHT NOTICE                                                           #
# Copyright 1998-2003 Matrix Science Limited  All Rights Reserved.           #
#                                                                            #
# This program may be used and modified within the licensee's organisation   #
# provided that this copyright notice remains intact. Distribution of this   #
# program or parts thereof outside the licensee's organisation without the   #
# prior written consent of Matrix Science Limited is expressly forbidden.    #
##############################################################################
#    $Archive:: /www/cgi/getseq.pl                                         $ #
#     $Author:: Johnc                                                      $ #
#       $Date:: 15/03/05 14:43                                             $ #
#   $Revision:: 12                                                         $ #
# $NoKeywords::                                                            $ #
##############################################################################
 use strict;                                                                #
##############################################################################
#
# header (optional)
#   missing or empty or 0 means output bare text
#   any other value means format as HTML page
#
# sessionID (optional)
#   if required by Mascot Server and this argument is missing or invalid,
#   script will return error number and error string
# 
# db (required)
#   see ms-getseq.exe
#
# accession (required)
#   see ms-getseq.exe
#
# type (required)
#   see ms-getseq.exe
#
# frame (optional)
#   see ms-getseq.exe
# 
# start (optional)
# end (optional)
#   start and end are special. They must be 1 based residue numbering for a peptide
#   translated from an NA sequence. The return is the NA sequence that corresponds
#   to the matched peptide. Used by peptide_view.pl.
#

  my(
  $accession,
  $arg_string,
  $db,
  $end,
  $errCode, 
  $frame,
  $NA,
  @output,
  $session,
  $sessionID,
  $start,
  $type,
  );
  
# set current directory to script location for FastTrack on NT
# chdir also handles a Windows drive letter change
  if ($ENV{'WINDIR'} && $0 =~ /(.*)[\\\/]/) {
    chdir($1);
  }

  use lib "../bin";
  use CGI;
  use msparser 1.002; # Do not change this. Script needs to be kept compatible with Mascot 2.0

# pull in the common subroutines
  require "./common_subs.pl";

  $| = 1; # set autoflush on STDOUT

# CGI object
  my $thisScript = new CGI;
  
  print $thisScript->header;
  if ($thisScript->param('header')) {
    &printHeader1("Matrix Science - Mascot - Unformatted sequence string");
    &printHeader2("", "Unformatted sequence string", 1);
  }
  
# provide backwards compatibility with 2.0 version of this script
  if ($thisScript->keywords) {
  # Mascot 2.0 syntax
    ($db, $accession, $type, $frame, $start, $end) = $thisScript->keywords;
  } else {
  # Mascot 2.1 syntax
    $db = $thisScript->param('db');
    $accession = $thisScript->param('accession');
    $type = $thisScript->param('type');
    $frame = $thisScript->param('frame');
    $start = $thisScript->param('start');
    $end = $thisScript->param('end');
  }

# untaint the arguments
  ($db) = $db =~ /([\w\.\-\$%&\(\)\[\]]+)/;
  ($accession) = $accession =~ /([!#-&\(-+\--_a-~]*)/; # all printing characters except "',`
  ($type) = $type =~ /(seq|all|len|title|pI)/;
  if ($start) {
    $start += 0;
  }
  if ($end) {
    $end += 0;
  }
  if (defined($frame) && $frame ne "") {
    $frame += 0;
  }

# check for required arguments
  unless ($db && $accession && $type) {
    &error(-1, "Required arguments missing or invalid");
  }

# are we permitted to access this database?
  $sessionID = "" unless ($sessionID = $thisScript->param('sessionID'));
# need to avoid error on Mascot 2.0 system
  eval { $session = new msparser::ms_session($sessionID); };
  unless ($@) {
    unless ($session->isValid && $session->isFastaPermitted($db)) {
      if ($thisScript->param('header')) {
        &go2login(&urlEscape($thisScript->self_url), $session->getLastError, &urlEscape($session->getLastErrorString));
        &printFooter;
        print "</BODY>\n";
        print "</HTML>\n";
        exit 1;
      } else {
        &error($session->getLastError, $session->getLastErrorString);
      }
    }
  }

# URL decode accession
  $accession =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex($1))/eg;
  
# create appropriate call to ms-getseq.exe
  if ($start && $end) {
    $arg_string = "../x-cgi/ms-getseq.exe $db \"$accession\" seq 0";
  } elsif ($frame) {
    $arg_string = "../x-cgi/ms-getseq.exe $db \"$accession\" $type $frame";
  } else {
    $arg_string = "../x-cgi/ms-getseq.exe $db \"$accession\" $type";
  }

  unless (open(SOCK, "$arg_string |")) {
    &error(-2, "Unable to open socket to $arg_string");
  }
    
  unless ($start && $end) {
  # save the returned text
    while (<SOCK>) {
      push @output, $_;
    }
  } else {
  # fish out NA sequence corresponding to peptide
    while (<SOCK>) {
      push @output, $_;
      if (/^\*(.+)/) {
        $NA = $1;
        if ($frame == 1) {
          $start = 3 * $start - 2;
          $end = 3 * $end;
          print substr($NA, $start-1, $end-$start+1) . " translated 5'3'\n";
        } elsif ($frame == 2) {
          $start = 3 * $start - 1;
          $end = 3 * $end + 1;
          print substr($NA, $start-1, $end-$start+1) . " translated 5'3'\n";
        } elsif ($frame == 3) {
          $start = 3 * $start;
          $end = 3 * $end + 2;
          print substr($NA, $start-1, $end-$start+1) . " translated 5'3'\n";
        } elsif ($frame == 4) {
          $start = length($NA) - 3 * $start + 3;
          $end = length($NA) - 3 * $end + 1;
          print substr($NA, $end-1, $start-$end+1) . " translated 3'5'\n";
        } elsif ($frame == 5) {
          $start = length($NA) - 3 * $start + 2;
          $end = length($NA) - 3 * $end;
          print substr($NA, $end-1, $start-$end+1) . " translated 3'5'\n";
        } elsif ($frame == 6) {
          $start = length($NA) - 3 * $start + 1;
          $end = length($NA) - 3 * $end - 1;
          print substr($NA, $end-1, $start-$end+1) . " translated 3'5'\n";
        }
      }
    }
  }
  
  if (close SOCK) {
  # success
    unless ($start && $end) {
    # just print the returned text
      foreach (@output) {
        unless (/^Content-type:/ || !/\w/) {
          if ($thisScript->param('header')) {
            if (/^\*/) {
              my $broken = join("<WBR>", (/.{1,60}/g));
              print "<BR>$broken\n";
            } else {
              print "<BR>" . &noTag($_) . "\n";
            }
          } else {
            print $_;
          }
        }
      }
    }
  } else {
  # problem
    my $sigCode = $? & 255;
    if ($sigCode > 0) {
      &error(-3, "$arg_string killed by system, signal was $sigCode");
    }
    $errCode = $? >> 8;
    foreach (@output) {
      if (/\[M(\d\d\d\d\d)]/) {
        &error($1, $_);
      }
    }
  # cannot find error number in text - shouldn't ever get here
    &error($errCode, "ms-getseq.exe error");
  }

# all done
  if ($thisScript->param('header')) {
    &printFooter;
    print "</BODY>\n";
    print "</HTML>\n";
  }

  exit 0;

###############################################################################
# &error()
# Print error message and exit
# $_[0] error number
# $_[1] error string
###############################################################################

sub error {
  
  if ($thisScript->param('header')) {
    print "error=$_[0]<BR>\n";
    print "errorstring=$_[1]<BR>\n";
    &printFooter;
    print "</BODY>\n";
    print "</HTML>\n";
  } else {
    print "error=$_[0]\n";
    print "errorstring=$_[1]\n";
  }

  exit 1;
  
}
