#!/usr/bin/perl -wT

use strict;
use warnings;

use IO::File;

use POSIX;
use CGI;
use CGI::Carp 'fatalsToBrowser';

delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};   # Make %ENV safer
$ENV{PATH} = '/bin:/usr/bin';

umask 2;

my $query = new CGI;


$query->print( $query->header, "\n" );
$query->print( $query->start_html('Cladogram Generator'), "\n" );

my $step = $query->param( 'step' );

if( not defined $step )
{
    $query->print( <<'    END', $query->br, "\n" );
    Enter the requested information in the fields below and then click the 'Run Analysis' button at the bottom
    to compute your cladogram. 

    Your last name is requested to enable storage of intermediate results in a way that does not conflict
    with that of other users. The number of taxa and number of characters should be integers in the corresponding
    fields; these are limited to reasonable numbers, which shouldn't be a problem for us.

    The taxa-characters matrix is entered in the large text area. Keep in mind the following constraints:
    <UL>
    <LI> Include one line per taxon.</LI>
    <LI> The first sequence of non-whitespace characters is treated as the taxon name. Use alphanumeric characters for this. A space should follow the taxon name.</LI>
    <LI> The character state values for each character follow in order, either 0-8 for your encoded values or ? for a missing or not-applicable state. One character per character! But note
that spaces are not required between characters.</LI>
    <LI> You should list your outgroup as the first species.</LI>
    <LI> You should <BOLD>not</BOLD> include a header row with column labels.</LI>
    <LI> You should <BOLD>not</BOLD> include extraneous punctuation or blank lines.</LI>
    </UL>
    Here is a sample matrix:
    <PRE>
    Alpha     110110
    Beta      110000
    Gamma     100110
    Delta     001001
    Epsilon   001110
    </PRE>
    If you have problems and have gone over the above constraints, drop me a line.
    <HR>
    <BR></BR>
    END
    #

    $query->delete( 'numtaxa', 'numchar', 'taxchar' );
    $query->print( $query->start_form('POST', $query->url()), "\n" );
    $query->print( 'Your Last Name (for storing results only): &nbsp;&nbsp;', $query->textfield( -name=>'lastname', -default=>'', -size=>20, -maxlength=>32 ), $query->br, "\n" );
    $query->print( $query->br, $query->br );
    $query->print( 'Number of Taxa: &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;', $query->textfield( -name=>'numtaxa', -default=>'', -size=>8, -maxlength=>8 ), $query->br, "\n" );
    $query->print( 'Number of Characters: &nbsp;&nbsp;', $query->textfield( -name=>'numchar', -default=>'', -size=>8, -maxlength=>8 ), $query->br, "\n" );
    $query->print( 'Taxa-Characters Matrix (see comments above):', $query->br,
                   $query->textarea( -name=>'taxachar', -default=>'', -rows=>32, -columns=>80 ), $query->br, "\n" );
    $query->print(  $query->br, "\n" );
    $query->param( 'step', 1 );
    $query->print( $query->hidden( 'step', 1 ), $query->br, "\n" );
    $query->print(  $query->br, "\n" );
    $query->print(  $query->submit( -name=>'run', -value=>'Run Analysis' ), '&nbsp;&nbsp;&nbsp;&nbsp;', $query->submit( -name=>'reset', -value=>'Clear Form' ), $query->br, "\n" );
    $query->print( $query->end_form, "\n" );
}
else
{
    # Setup working files if they don't already exist
    # Some concurrency risk here but shouldn't happen so for now I'll live with it.

    system "rm -rf /tmp/cladogram.files";



    my $Bin = "/home/GERYON/genovese/bin/phylip/pars";
    my $Dir = "/tmp/cladogram_files";

    if( ! -e $Dir )
    {
        mkdir( $Dir ) || die "Cannot make working directory $Dir. If you haven't already, try again.";

        my $fh;

        $fh = new IO::File( "> $Dir/outfile" ) || die "Cannot create outfile in $Dir";
        print $fh " \n";
        $fh->close;

        $fh = new IO::File( "> $Dir/outtree" ) || die "Cannot create outfile in $Dir";
        print $fh " \n";
        $fh->close;
    }

    chdir $Dir  or  die "Can't change to working directory";

    #
    # Unique mode (a bit weak but should be enough for now ATTN)
    #

    my $lastname = $query->param('lastname');

    $lastname =~ /\A\s*(\w+)\s*\Z/;
    my $mode = "$1-$$-" . time();

    #
    # Create input
    #

    my $ifh = new IO::File( "> inspec.$mode" );

    print $ifh <<"    END";
infile.$mode
F
outfile.$mode
Y
F
outtree.$mode
    END
    #

    $ifh->close;

    #
    # Parse form input
    #

    my $numtaxa = $query->param( 'numtaxa' );

    if( defined($numtaxa) && $numtaxa =~ m/\A\s*([1-9]\d*)\s*\Z/ )
    {
        $numtaxa = $1;

        die "Too many taxa $numtaxa" if( $numtaxa > 100 ); # This is arbitrary, but tough!
    }
    else
    {
        die "Number of taxa not properly set in form.\n";
    }

    my $numchar = $query->param( 'numchar' );

    if( defined($numchar) && $numchar =~ m/\A\s*([1-9]\d*)\s*\Z/ )
    {
        $numchar = $1;

        die "Too many characters $numchar" if( $numchar > 100 ); # This is arbitrary, but tough!
    }
    else
    {
        die "Number of characters not properly set in form.\n";
    }

    my $taxachar = $query->param( 'taxachar' );
    my @tcmat;

    if( defined($taxachar) && $taxachar =~ m/\A([\s\w\?]+)\Z/sm )
    {
        $taxachar = $1;
        $taxachar =~ s/\015\012?/\n/g;

        @tcmat = split( /\n/, $taxachar );

        for( my $i = 0; $i < scalar(@tcmat); ++$i )
        {
            $tcmat[$i] =~ s/\A(\S+)\s+/sprintf( "%-10s", substr( $1, 0, 10 ) )/e;
        }
    }
    else
    {
        $query->print( "A <BR><PRE>", $taxachar, "</PRE><BR>B\n", $query->br );
        die "Ill-formed taxa-characters matrix. See notes and provisos in form instructions.\n";
    }


    $ifh = new IO::File( "> infile.$mode" ) || die "Cannot open infile";

    printf $ifh "    %d    %d\n%s\n", $numtaxa, $numchar, join( "\n", @tcmat );

    $ifh->close;

    #
    # Run analysis
    #

    my $exit = system( "cat inspec.$mode | $Bin >& log.$mode" );

    $exit/= 256;

    $query->print( "ERROR $exit in program run", $query->br ) if( $exit );

    if( -e "outfile.$mode" )
    {
        my $outfh = new IO::File( "< outfile.$mode" );

        my @lines = $outfh->getlines;

        $query->print( $query->pre( join( "", @lines ) ), $query->br, $query->br, "\n" );
    }

    $query->delete('step');

    $query->print( $query->start_form('POST', $query->url()), "\n" );
    $query->print(  $query->submit( -name=>'again', -value=>'Do it again' ), $query->br, "\n" );
    $query->print( $query->end_form, "\n" );

    $query->print( $query->br, $query->br, "\n" );
    $query->print( $query->span( {-style=>'font-size: small;'}, "This script makes use of the following software and is for course use only: Felsenstein, J. 2004. PHYLIP (Phylogeny Inference Package) version 3.65. Distributed by the author. Department of Genome Sciences, University of Washington, Seattle. PHYLIP is under copyright 1980-2004. University of Washington and Joseph Felsenstein. All rights reserved. Permission is granted to reproduce, perform, and modify these programs and documentation files. Permission is granted to distribute or provide access to these programs provided that this copyright notice is not removed, the programs are not integrated with or called by any product or service that generates revenue, and that your distribution of these documentation files and programs are free. Any modified versions of these materials that are distributed or accessible shall indicate that they are based on these program. Institutions of higher education are granted permission to distribute this material to their students and staff for a fee to recover distribution costs. Permission requests for any other distribution of this program should be directed to  license @ u.washington.edu ." ), $query->br, "\n" );

}



$query->print( $query->end_html, "\n" );




# Local Variables:
# mode: perl;
# End: