#!/usr/bin/perl -w
#$Id: collect2,v 1.26 2005/02/19 05:56:00 hchen Exp $

use strict;
use Cwd;
use File::Basename;
use Getopt::Long qw(:config gnu_compat bundling_override pass_through);
use File::Temp qw/ tempfile tempdir /;
use FileHandle;
use lib dirname($0) . "/../lib";
use Util;

my (# executables
    $MOPS_UI_GEN, $MOPS_GCC_COLLECT2, $MOPS_AR, $MOPS_JAVA, $MOPS_OBJCOPY,
    $MOPS_MV,
    # user-configurable variables
    $MOPS_RUN_LEVEL, $MOPS_ENABLE, $MOPS_TEMPDIR, $MOPS_MFSAS,
    $MOPS_CFGDIR, $MOPS_TEXTTRACEDIR, $MOPS_HTMLTRACEDIR,
    $MOPS_PROFILE, $MOPS_CLASSPATH);

my ($MOPS_LD_MCFG, $MOPS_SCAN_USR_LIB, $profile, $outputFile, $outname,
    $ui_dir, @savedARGV);

sub runRealLd()
{
  my ($rc, @cmd);

  if (!defined($MOPS_LD_MCFG))
  {
    $rc = runSysCmd($MOPS_GCC_COLLECT2, @savedARGV);
    if ($rc == 0)
    {
      debug("Removing MOPS metadata from executable\n");
      @cmd = ($MOPS_OBJCOPY, "-R", ".MOPS", $outputFile);
      $rc = runSysCmd(@cmd);
      if ($rc != 0)
      {
	warn("$MOPS_OBJCOPY returns $rc: unable to remove MOPS section from output.\n");
      }
      $rc = 0;
    }
  }
  else
  {
    $rc = 0;
  }

  # Put the profiling information in the right place.
  # Don't profile this command!
  if (defined($ui_dir) && -d "$ui_dir/" . $outname)
  {
    debug("Relocating profiling information\n");
    system($MOPS_MV, $profile, "$ui_dir/" . $outname);
  }

  return $rc;
}

sub absolutify($)
{
  my ($file) = @_;

  if (substr($file, 0, 1) eq "/")
  {
    return $file;
  }
  else
  {
    return getcwd() . "/" . $file;
  }
}

sub isArchive($)
{
  my ($filename) = @_;

  return system("$MOPS_AR t $filename > /dev/null 2>&1") == 0;
}

sub resolveLib($$)
{
  my ($libname, $libsearch) = @_;
  my ($filename, $dir);
  
  for $dir (@$libsearch)
  {
    $filename = "$dir/lib$libname.a";
    if (-f $filename)
    {
      return $filename;
    }
  }
  info("Cannot resolve library $libname\n");
  return undef;
}

sub extractCfg($$)
{
  my ($objfile, $outdir) = @_;
  my ($cfgfile, $rc);

  if (!$MOPS_SCAN_USR_LIB && $objfile =~ m#^/usr/(lib|X11R6)/#)
  {
    info("$objfile will not be checked for CFG\n");
    return undef;
  }
  (undef, $cfgfile) = tempfile($outdir . "/" . myBaseName($objfile) .
			       "-XXXX", SUFFIX => ".cfg", UNLINK => 1);
  # Extract the .MOPS section from the object file
  if (($rc = runSysCmd($MOPS_OBJCOPY, "-j", ".MOPS", "-O", "binary", 
		   $objfile, $cfgfile)) != 0)
  {
    return undef;
  }
    
  # If the resulting .cfg is empty, we don't have anything to use;
  # delete the empty file.
  if ((!-f $cfgfile) || (-z $cfgfile))
  {
    info("$objfile does not contain a CFG\n");
    return undef;
  }
  return $cfgfile;
}

sub run_javacmd(@)
{
  my (@cmd) = @_;
  my @JAVA_ARGS = ("-Xmx1024m", "-cp", $MOPS_CLASSPATH);
  #my $profile = $tracedir . "/profile";
  my ($programName, $rc);
  
  $programName = shift @cmd;
  unshift @cmd, $MOPS_JAVA, @JAVA_ARGS, $programName, "-v",
  $Verbose[getVerbosity()], "-E", getLogFile();

  $rc = runSysCmd(@cmd);
  if ($rc != 0)
  {
    error($cmd[@JAVA_ARGS + 1], " returned $rc\n");
    end(1);
  }
}

sub update_index($$)
{
  my ($mfsas, $numtraces) = @_;
    my (@idx_mfsas, @idx_programs, %idx_traces);
    my ($mfsa, $prog);


    if (-f $ui_dir . "/index.html") {
	my ($line, $state);
	open BINIDX, $ui_dir . "/index.html" or
	    warn("Unable to open index: $!\n");

	$state = "head";
	while ($line = <BINIDX>) {
	    chomp $line;

	    # Skip the fixed header
	    if ($state eq "head") {
		$state = "mfsas" if $line eq "  <td width=60>&nbsp;</td>";;
	    }

	    # Read the existing MFSAs from the index
	    elsif ($state eq "mfsas") {
		if ($line =~ m|^  <td align=center>&nbsp;(.+)&nbsp;</td>|) {
		    push @idx_mfsas, $1;
		}
		else {
		    $state = "row_skip";
		}
	    }

	    # Advance to the beginning of the next row
	    elsif ($state eq "row_skip") {
		$state = "row" if $line eq "<tr>";
		last if $line eq "</table>";
	    }

	    # Store the number of traces for another program
	    elsif ($state eq "row") {
		if ($line !~ m[^  <td align=right>(.+)&nbsp;</td>]) {
		    warn("Line $. malformed in index ",
			  "(expected program name)\n");
		    $state = "row_skip";
		    next;
		}
		$prog = $1;
		push @idx_programs, $prog;
		foreach $mfsa (@idx_mfsas) {
		    chomp($line = <BINIDX>);
		    if ($line !~ m[
				   ^\ \ <td\ align=center>
			           (?:<a[^>]*>)?
				   (\d+)
				   (?:</a>)?
				   </td>$
				   ]x) {
			warn("Line $. malformed in index ",
			      "(expected trace count)\n");
			last;
		    }
		    my $count = $1;
		    $idx_traces{$prog}{$mfsa} = $count;
		}
		$state = "row_skip";
	    }

	    # Unknown state -- this really, really shouldn't happen
	    else {
		warn("State machine in invalid state -- huh?\n");
	    }
	}

	close BINIDX;
    }

    for $mfsa (map { $_ = fileparse($_, ".mfsa") } @$mfsas) {
	push @idx_mfsas, $mfsa unless grep { $_ eq $mfsa } @idx_mfsas;
    }
    push @idx_programs, $outname unless grep { $_ eq $outname } @idx_programs;
    for $mfsa (@idx_mfsas) {
	$idx_traces{$outname}{$mfsa} = $numtraces->{$outname}{$mfsa} || 0;
    }


    debug("MFSAs: ", join(' ', @idx_mfsas), "\n");

    # Print the common HTML header
    my $cols = @idx_mfsas + 1;
    open BINIDX, "> " . $ui_dir . "/index.html" or
	     warn("Unable to create index: $!\n");
    print BINIDX fixup_heredoc(<<"	EOF");
	@@<html>
	@@<head>
	@@<title>MOPS Output</title>
	@@</head>
	@@
	@@<body bgcolor="#ffffff">
	@@<center><h2>MOPS Results</h2></center><br>
	@@<table border=1 cellpadding=2 cols=$cols>
	@@<tr>
	@@  <td width=60>&nbsp;</td>
	EOF
	;

    # Generate the table header
    for $mfsa (@idx_mfsas) {
	print BINIDX "  <td align=center>&nbsp;$mfsa&nbsp;</td>\n";
    }
    print BINIDX "</tr>\n";

    # Generate table contents
    for $prog (@idx_programs) {
	print BINIDX "<tr>\n";
	print BINIDX "  <td align=right>$prog&nbsp;</td>\n";
	for $mfsa (@idx_mfsas) {
	    my $count =  $idx_traces{$prog}{$mfsa};
	    print BINIDX "  <td align=center>";
	    print BINIDX "<a href=\"$prog/$mfsa/index.html\">" if $count;
	    print BINIDX "$count";
	    print BINIDX "</a>" if $count; 
	    print BINIDX "</td>\n";
	}
	print BINIDX "</tr>\n";
    }

    # Print HTML footer
    my $date = localtime();
    print BINIDX fixup_heredoc(<<"	EOF");
    @@</table>
	@@<p>
	@@<hr>
	@@ This file was generated on $date.
	@@</body>
	@@</html>
	EOF
	;

    close BINIDX;

}

setLogFile($ENV{MOPS_LOG});
begin();

## Save ARGV so we can run real ld later
@savedARGV = @ARGV;

## Make sure we can get everything we need from the environment
my ($MOPS_RUN_LEVEL_CFG, $MOPS_RUN_LEVEL_TRACE, $MOPS_RUN_LEVEL_HTML);
$MOPS_RUN_LEVEL_CFG = 0;
$MOPS_RUN_LEVEL_TRACE = 1;
$MOPS_RUN_LEVEL_HTML = 2;

foreach my $var (qw(MOPS_UI_GEN MOPS_GCC_COLLECT2 MOPS_AR MOPS_JAVA MOPS_OBJCOPY
		    MOPS_MV
		    MOPS_RUN_LEVEL MOPS_ENABLE MOPS_TEMPDIR
		    MOPS_MFSAS MOPS_CFGDIR MOPS_TEXTTRACEDIR
		    MOPS_HTMLTRACEDIR MOPS_PROFILE MOPS_CLASSPATH))
{
  if (!defined($ENV{$var}))
  {
    if (!(($var eq "MOPS_MFSAS" ||
	   $var eq "MOPS_TEXTTRACEDIR" ||
           $var eq "MOPS_HTMLTRACEDIR") &&
	  $MOPS_RUN_LEVEL <= $MOPS_RUN_LEVEL_CFG) &&
	!($var eq "MOPS_CFGDIR" && $MOPS_RUN_LEVEL > $MOPS_RUN_LEVEL_CFG))
    {
      info("Environment variable $var not set, disabling MOPS\n");
      end(1);
    }
  }
  else
  {
    eval "\$$var = \"$ENV{$var}\"";
    debug("$var = ", eval("\$$var"), "\n");
  }
}
# Other, noncritical environment variables
$MOPS_SCAN_USR_LIB = $ENV{MOPS_SCAN_USR_LIB} or 0;
#my $MOPS_PRECIOUS = $ENV{MOPS_PRECIOUS} or 0;
$MOPS_LD_MCFG = $ENV{MOPS_LD_MCFG} or undef;
my $mops_prefixswap = $ENV{MOPS_PREFIXSWAP} or undef;
my @dirPrefixes;
@dirPrefixes = split(/;/, $mops_prefixswap) if (defined($mops_prefixswap));

if (!$MOPS_ENABLE)
{
  end(runRealLd());
}

$profile = $MOPS_PROFILE;
unlink($profile);
setProfile($profile);

my $cfgdir = $MOPS_CFGDIR;
my $tracedir = $MOPS_TEXTTRACEDIR;
$ui_dir = $MOPS_HTMLTRACEDIR;
my $tempdir = $MOPS_TEMPDIR;

## Parse command-line options
my ($entry, $incremental, @libs, @libSearch, @libFiles, %libs, %libSearch,
    %libFiles, $shlib, $unused);
GetOptions("dynamic-linker|m|O=s" => \$unused,
	   "E|EB|EL|g|S|s|t" => \$unused,
	   "export-dynamic" => \$unused,
	   "e|entry" => \$entry,
	   "i|r" => \$incremental,
	   "l|library=s" => \@libs,
	   "L|library-path=s" => \@libSearch,
	   "o|output=s" => \$outputFile,
	   "shared|Bshareable" => \$shlib,
           "eh-frame-hdr" => \$unused,
	   "soname=s" => \$unused,
           "as-needed" => \$unused,
           "no-as-needed" => \$unused,
           "pie" => \$unused);

# remove duplicate entries in @libs or @libSearch
for my $lib (@libs)
{
  $libs{$lib} = undef;
}
for my $lib (@libSearch)
{
  $libSearch{$lib} = undef;
}
$entry = "main" unless $entry;
$outputFile = "a.out" unless $outputFile;
$outname = basename($outputFile);
if ($incremental)
{
  error("MOPS does not support incremental linking\n");
  end(runRealLd());
}
#if ($shlib) {
#    &info("Modelchecking deferred until program linking\n");
#    &ld_end;
#}

## Pull the CFGs out of the object files
my (@cfgs, $cfg);

# Handle objects specified on the command line
for my $obj (@ARGV)
{
  if ($obj =~ /^-/ && ! -f $obj)
  {
    warn("$obj looks like an unhandled option -- skipping.\n");
    next;
  }
  if (isArchive($obj))
  {
    $libFiles{$obj} = undef;
    next;
  }
  if (defined($cfg = extractCfg($obj, $tempdir)))
  {
    push @cfgs, $cfg;
  }
}

# Handle archives
my ($arOutputFile, $fh, $lib, $libDir, $filename, $str);
my $savedCwd = getcwd();
# Resolve -lfoo into /path/to/libfoo.a
@libSearch = keys %libSearch;
for $lib (@libs)
{
  $filename = resolveLib($lib, \@libSearch);
  $libFiles{$filename} = undef if (defined($filename));
}

# Extract CFGs from archives
$fh = new FileHandle;
for my $lib (keys %libFiles)
{
  next if (!(-f $lib) || (!$MOPS_SCAN_USR_LIB && $lib =~ m#^/usr/(lib|X11R6)/#));
  $lib = absolutify($lib);
  $libDir = tempdir($tempdir . "/" . basename($lib) . "-XXXX", CLEANUP => 1);
  chdir($libDir) or (warn("Unable to chdir to temp dir: $!\n") && next);
  (undef, $arOutputFile) = tempfile($tempdir . "/arout-XXXX", UNLINK => 1);
  if (runSysCmd($MOPS_AR, "xv", $lib, { STDOUT => $arOutputFile }) != 0)
  {
    warn("Execution of $MOPS_AR failed: $!\n");
    next;
  }
  $fh->open($arOutputFile) or
    (warn("Cannot open $arOutputFile for reading: $!\n") && next);
  while ($str = <$fh>)
  {
    next if ($str =~ /^\s*$/);
    if ($str !~ /([^\s]+)\s*$/)
    {
      warn("Cannot parse output from $MOPS_AR xv $lib: $str\n");
      last;
    }
    $filename = $1;
    if (defined($cfg = extractCfg($filename, $libDir)))
    {
      push @cfgs, $cfg;
    }
    unlink($filename) or warn("Unable to unlink $filename: $!\n");
  }
  $fh->close();
}	 
continue
{
  chdir($savedCwd) or warn("Unable to return to working dir $savedCwd: $!\n");
}

## Alright, we're finally ready to run MOPS
my (@cmd, $rc);
# If the user already has the merged CFG and only wants to model check it,
# then skip CfgMerge.
my ($mcfg);
if (defined($MOPS_LD_MCFG))
{
  $mcfg = $MOPS_LD_MCFG;
  $outname = basename($MOPS_LD_MCFG, ".mcfg");
  # be aware that $mcfg may not be in $cfgdir, but ld will create
  # working files in $cfgdir anyway.
}
else
{
  if (scalar(@cfgs) == 0)
  {
    info("No CFGs in input files -- skipping modelchecking.\n");
    end(runRealLd());
  }
  debug("CFGs: @cfgs\n");

  # Merge only once
  (undef, $mcfg) = tempfile($cfgdir . "/" . $outname . "-XXXX",
			    SUFFIX => ".mcfg");
  @cmd = ("CfgMerge", "-o", $mcfg, @cfgs);
  &run_javacmd(@cmd);
  #runSysCmd($MOPS_COLLECT2, "-o", $mcfg, @cfgs);

  # Clean temporary directories used by AR
#  my ($cfg);
#   for $cfg (@cfgs)
#   {
#     unlink($cfg) or &warn("Unable to unlink archive CFG $cfg: $!\n");
#   }
#   for $libdir (@libdirs)
#   {
#     rmdir($libdir) or &warn("Unable to rmdir $libdir: $!\n");
#   }
}

# Stop here if MOPS_RUN_LEVEL==0
if ($MOPS_RUN_LEVEL <= $MOPS_RUN_LEVEL_CFG)
{
  end(runRealLd());
}

# Allow multiple MFSAs
my ($list, @mfsas, $mfsa, %numtraces, $i);
{
$list = "";
@mfsas = split /:/, $MOPS_MFSAS;
for $mfsa (@mfsas) {
    debug("Using MFSA $mfsa\n");
    my $mfsabase = fileparse($mfsa, ".mfsa");
    my $outdir = $tracedir . "/" . $mfsabase;
    if (! -d $outdir) {
	mkdir $outdir or warn("Unable to create strace subdirectory: $!\n");
    }

    # Compact
    my ($ccfg);
    $ccfg = $tempdir . "/" . $outname . "." . $mfsabase . ".ccfg";
    @cmd = ("CfgCompact",
	    "-m", $mfsa,  "-i", $mcfg, 
	    "-e", $entry, "-o", $ccfg);
    run_javacmd(@cmd);

    # Check
    @cmd = ("Check",
	    "-m", $mfsa,  "-i", $ccfg,
	    "-e", $entry, "-o", $outdir . "/" . $outname . ".s");
    run_javacmd(@cmd);

    # Transform
    @cmd = ("Transform",
	    "-c", $mcfg, "-i", $outdir . "/" . $outname . ".s",
	    "-o", $outdir . "/" . $outname);
    for $i (0 .. $#dirPrefixes)
    {
      push @cmd, "-p", $dirPrefixes[$i];
    }
    run_javacmd(@cmd);

    # The UI generation script needs the text version of the MCFG
    # @cmd = ("Bin2Text", "-i", $mcfg, "-o", $mcfg . ".txt");
    # &run_javacmd(@cmd);

    next if ($MOPS_RUN_LEVEL <= $MOPS_RUN_LEVEL_TRACE);
    # Generate UI
    info("Deleting contents of $ui_dir/" . $outname . "/$mfsabase\n");
    clean_dir($ui_dir . "/" . $outname . "/$mfsabase");
    @cmd = ($MOPS_UI_GEN);
    push @cmd, "-v" if getVerbosity() >= $DEBUG;
    push @cmd, "-g", getLogFile(),
	    "-f", $outname,
	    "-o", $ui_dir . "/" . $outname . "/" . $mfsabase,
	    $outdir . "/" . $outname;
    $rc = runSysCmd(@cmd);
    if ($rc != 0) {
	error("UI generation returned $rc\n");
	end(1);
    }

    # Generate an HTML list item for the MFSA
    my ($tracecount);
    open TRACE, $outdir . "/" . $outname;
    while (<TRACE>) {
	chomp;
	$tracecount++ if -e $_;
    }
    $numtraces{$outname}{$mfsabase} = $tracecount;
    close TRACE;

    # Symlink all the relevant images/include files
    for my $file (qw(pad.png expand.png collapse.png noop.png
		     trace.js trace.css)) {
	if (! -f $ui_dir . "/" . $file) {
	    @cmd = ("cp", dirname($0) . "/../lib/" . $file, $ui_dir);
	    system(@cmd); # Don't want profiling, so use system directly
	}
	symlink("../../$file", 
		"$ui_dir/" . $outname . "/$mfsabase/$file");
    }
}

if ($MOPS_RUN_LEVEL >= $MOPS_RUN_LEVEL_HTML)
{
# Create top-level index (list of binaries)
  debug("Updating program index\n");
  update_index(\@mfsas, \%numtraces);
}
}

end(runRealLd());


# sub fileEquals($$)
# {
#   my ($dev1, $ino1, $dev2, $ino2);

#   ($dev1, $ino1) = stat($_[0]) or return 0;
#   ($dev2, $ino2) = stat($_[1]) or return 0;
#   return $dev1 == $dev2 && $ino1 == $ino2;
# }
