#!/usr/bin/perl
#
#
# Copyright (c) 2001-2002, 
#  George C. Necula    <necula@cs.berkeley.edu>
#  Scott McPeak        <smcpeak@cs.berkeley.edu>
#  Wes Weimer          <weimer@cs.berkeley.edu>
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# 3. The names of the contributors may not be used to endorse or promote
# products derived from this software without specific prior written
# permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
use strict;
use CGI;
use Cwd;
use FindBin;
# use Archive::Tar;
use Data::Dumper;
use File::Copy;

BEGIN {
    # log errors to local file
    use CGI::Carp qw(carpout);
#    open(ERROR_LOG, ">>./error_log") or
#	die("Unable to open error log file: $!\n");
#    carpout(\*ERROR_LOG);
    carpout(\*STDOUT);
}


use lib "$FindBin::Bin/../cil/bin"; # To get CilConfig.pm
use CilConfig;
use lib "$FindBin::Bin/../lib"; # To get CilConfig.pm
use Deputy;


# make newly-created files user-writable
umask 002;

$| = 1; # No buffering of output


# Keep all directories relative to $::deputyhome
my $TEMPFILESDIR = "web/tmp";

# How to reach $::deputyhome from where this script is
my $relative_cil_home = "..";

# These are the standard tests
my %standardTests = 
    ( 'array2' => &smallTest('array2'),
);
 
my $cgi = new CGI;

print $cgi->header(-expires => 'now',
                   -title => "Deputy demo results");


# Just for debugging
# print $cgi->Dump();

#check if program being run from command line or remotely
my $LOCAL = ($cgi->remote_addr() eq '127.0.0.1');

my $testinfo = &prepareFiles();

my $cwd = Cwd::cwd();

# Now we are running the test
chdir "$::deputyhome/$testinfo->{DIRECTORY}" 
    || die "$!: $::deputyhome/$testinfo->{DIRECTORY}";
# Prepare the arguments
my @args = ( '--verbose',
             '--stats',
             '--save-temps=.');
my $deputy = 
    "$::deputyhome/bin/deputy " .
    join(' ', @args) . ' ' . 
    $testinfo->{FLAGS};
# Now add whatever argument we got from the form
foreach my $arg ($cgi->param()) {
    if($arg =~ m|^--|) {
        $deputy .= " $arg";
    }
}
# Now finish the command line
$deputy .= ' ' .  join(' ', @{$testinfo->{SOURCEFILES}}) .
    " -o $testinfo->{BASENAME}.o";

print "<!--\n$deputy\n-->\n";
if(! open(OUT, "$deputy 2>&1 |")) {
    die <<EOF;
Cannot run Deputy<br>
See the source of this page for more details about this run.
EOF
}

print "The Deputy demo is in progress. Please wait...<BR>\n";
print "<!--\n"; # Put most of the stuff in comments
my $statistics = 0;
my $errors = 0;
while(<OUT>) {
    $_ =~ s|CABS->CIL|CABS to CIL|;

    if($_ =~ m|^ptrkinds:(.*)$|) {
        print "-->$1\n<BR><!--\n";
    }
    # Show the statistics
    if($_ =~ m|^Static count of CHECKs|) {
        print "--><PRE>\n"; 
        while(<OUT>) {
            if($_ !~ m|CHECK_|) { last; }
            print $_;
        }
        print "</PRE><!--\n";
    }
    print $_;
}

# Now close the output
if(! close(OUT)) {
    die <<EOF;
-->
Error running Deputy
See the source of this page for more details about this run.
EOF
}
chdir $cwd;

print "-->";

# Show the result
print "Deputy completed succesfully!<BR>\n";

my $basedir = "$relative_cil_home/$testinfo->{DIRECTORY}";
my $deputyout = "$basedir/$testinfo->{BASENAME}.cil.c";
print "Check out the <a href=\"$deputyout\">result</a>";

# print Dumper($testinfo);

# Now show the browser
#if(! -d $browserdir) {
#    $browserdir = "$basename/$testinfo->{BASENAME}.o_comb.browser";
#    if(! -d $browserdir) {
#        die "Cannot find the browser directory\n";
#    }
#}
#print <<EOF;
#-->
#<iframe width='100%' height='100%' src='$browserdir/index.html'>
#Your browser does not support the IFRAME HTML element. This demo works better
#with Microsoft Internet Explorer 6.0, Netscape 6.0, or Mozilla 1.0<br>
#You can see the result of the run 
#<a target=_blank href='$browserdir/index.html'>here</a>.
#</iframe>;
#EOF


# Go over the temporary directories and delete those that are older than 
# a few days
opendir TESTDIR, "$::deputyhome/$TEMPFILESDIR";
my @temps = grep {/^\d+/ && -d $_ && -C $_ > 1} readdir TESTDIR;
closedir TESTDIR;
foreach my $tmp (@temps) {
    system("rm -r $::deputyhome/$TEMPFILESDIR/$tmp");
}

exit(0);

########## Subroutines

# Construct the info for a test from small
sub smallTest {
    my ($basename) = @_;
    return { DIRECTORY => "test/small",
             BASENAME => $basename,
             SOURCEFILES => [ "$basename.c" ],
             FLAGS => '-c' }
}

#
# Prepare the files that we must work on 
sub prepareFiles {
    my $testname = $cgi->param('testname');
    my $handle = $cgi->upload('file');
    if(defined $testname && $testname ne "" && defined $handle) {
        die "Both a resident and an upload test were specified";
    }
    if(defined $testname && $testname ne "") {
        #This is one of our standard tests
        if(! defined($standardTests{$testname})) {
            die "Unknown resident test name: $testname";
        }
        return $standardTests{$testname};
    }
    # Not a resident test name. Hope for a .i file
    if(defined $handle) {
	#get content-type of file (nothing if not filehandle)
	my $contentType = $cgi->uploadInfo($handle)->{'Content-Type'};
        # Check the file name. Return the basename
        my $basename = &checkFileName($handle);
        print "The basename is $basename\n";
        my $tdir = &makeTempDir();
        open(SAVED, ">$::deputyhome/$tdir/$basename.i") 
            || die "Cannot copy uploaded file to $::deputyhome/$tdir";
        my $buffer;
        while(read($handle,$buffer,1024)) {
            print SAVED $buffer;
        }
        close(SAVED);
        return  { DIRECTORY => "$tdir",
                  SOURCEFILES => [ "$basename.i" ],
                  FLAGS => '--nomerge -c',
                  BASENAME => $basename };
    }
    die "Neither a resident test nor an upload file was specfied";
}

# Check a file name. It must be a preprocessed file
sub checkFileName {
    my $filename = shift;
    if($filename =~ m|^(.+[/\\])?([a-zA-Z0-9_.]+).i$|) {
        return $2;
    }
    die "Invalid filename: $filename. It must be a preprocessed file with
extension .i!";
}

# Make a temporary directory.
# Also delete old directories
sub makeTempDir {
    my $timestamp = time(); # We use this to create fresh directory names

    # Now find a good name
    my $TEMPDIR;
    do {
        $TEMPDIR = "$TEMPFILESDIR/$timestamp";
        # Go back in time a bit to ensure a new name
        $timestamp --;
    } while(-d "$::deputyhome/$TEMPDIR");
    mkdir "$::deputyhome/$TEMPDIR";
    return $TEMPDIR;
}

# Search for strange characters that could lead to security vulnerabilities
sub validateArgument {
    my($arg) = @_;
    if($arg =~ m|[^0-9a-zA-Z_]|) {
        die "Invalid character in $arg";
    }
}

sub checkTar {
    my $tarFiles = shift;
    my $file = undef;
    foreach $file (@$tarFiles) {
	if (($file !~ m/\.[cih]$/i) || $file =~ m/\//) {
            print qq(ERROR: tar file does not satisfy constraints\n<BR>);
	    return 0;
	}
    }
    return 1;
}


#  printUploadHeaders() prints a list of the file upload headers
#  associated with a given filename
#  useful for debugging
#
sub printUploadHeaders() {
    my $filename = shift;
    print "headers:\n<BR>";
    my $headersRef = $cgi->uploadInfo($filename);
    my $key = undef;
    foreach $key (keys (%$headersRef)) {
	print "$key -> " . $headersRef->{$key} . "<BR>\n";
    }
}

# done, deputy generated the appropriate files.
# open the input file

__END__
:endofperl