#!/usr/bin/env perl

# Convenient interface to the Daikon annotation front-end for Perl programs
# $Id$

# This file is part of the Daikon distribution. It may be used and
# redistributed under the same terms as the rest of Daikon or, at your
# option, under the same terms as Perl itself, following either the
# GNU General Public License or the Perl Artistic License.  The Daikon
# Perl front end, of which this file is a part, and the Daikon dynamic
# invariant detection tool are separate programs, neither derived from
# the other, which are merely aggregated for convenience of
# distribution. As such, licensing the Perl front end under the terms
# of the GPL neither requires nor entitles you to license other parts
# of the Daikon distribution under the same terms.

use strict;
use 5.006;
use warnings;
BEGIN {
    require English;
    if ($^V ge 5.8.0) {
        English->import("-no_match_vars"); # avoid speed penalty
    } else {
        English->import();
    }
}

use Getopt::Long ();
#use Carp ('carp', 'croak', 'cluck', 'confess');
use File::Path 'mkpath';
use File::Basename;
use File::Spec::Functions 'rel2abs';
use File::Find;
use Cwd 'getcwd';

my $verbose = 0;
my $perl = $EXECUTABLE_NAME;

my $use_types = 0;
my $use_accessors = 0;
my @types_files = ();
my $types_search = undef;

my $accessors_search = undef;

my $instr_basedir = undef; # defaults to daikon-{untyped,instrumented}
                           # depending on whether we have type information.
my $types_basedir = undef; # default to daikon-instrumented

my $decls_basedir = undef;
my $dtrace_basedir = undef;
my $output_dir = undef;

my $types_style = undef; # defaults to tree
my $decls_style = undef; # now always matches types_style
my $dtrace_style = "combined";

my $types_append = 1;
my $dtrace_append = 0;

my $absolute = undef;
my $instr_absolute = undef;
my $types_absolute = undef;
my $decls_absolute = undef;
my $dtrace_absolute = undef;

my $reference_depth = 3;
my $accessor_depth = 1.5;
my $list_depth = 3;

my $do_usage = 0;

sub careful_system {
    my @cmd = @_;
    die unless @cmd > 1; # Avoid the shell
    if ($verbose) {
        my @nice_args = @cmd;
        # So that our output looks like make or shell script output,
        # do an approximation to shell quoting on the verbose
        # output. Note that because we always use the multi-arg form
        # of system, we don't have to worry about shell-escaping the
        # actual args we pass to the command, which is convenient.
        for my $arg (@nice_args) {
            $arg = "'$arg'" if $arg =~ / /;
        }
        print join(" ", @nice_args), "\n";
    }
    my $result = system(@cmd);
    if ($result != 0) {
        die "External command failed: " . join(" ", @cmd);
    }
    return $result;
}

sub file_id {
    my($fname) = @_;
    my($dev, $inode) = stat($fname) or die "Couldn't stat $fname: $!\n";
    return "$dev:$inode";
}

my @found_modules = ();

sub is_module {
    my ($dev,$ino,$mode,$nlink,$uid,$gid);

    if ((($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
        -f _ && /^.*\.pm\z/s) {
        push @found_modules, $File::Find::name;
        print "Found module $File::Find::name\n" if $verbose;
        return 1;
    }
}

use File::Basename;
my $dirname = dirname(__FILE__);

my $opt_parse = new Getopt::Long::Parser;
$opt_parse->configure("bundling_override");
my $parsed =
  # Some deprecated (outdated) option names are still supported.
  $opt_parse->getoptions("instrsourcedir|instr-basedir|instr-dir=s"
                           => \$instr_basedir,
                         "types-basedir=s" => \$types_basedir,
                         "decls-basedir|decls-dir=s" => \$decls_basedir,
                         "dtrace-basedir|dtrace_dir=s" => \$dtrace_basedir,
                         "output-dir=s", => \$output_dir,
#                        "instr-style=s" => \$instr_style,
                         "types-style=s" => \$types_style,
                         "decls-style=s" => \$decls_style,
                         "dtrace-style=s" => \$dtrace_style,
                         "types-append!" => \$types_append,
                         "dtrace-append!" => \$dtrace_append,
                         "use-types|T" => \$use_types,
                         "types-file|t=s" => \@types_files,
                         "types-dir:s" => \$types_search,
                         "use-accessors|A" => \$use_accessors,
                         "accessors-dir:s" => \$accessors_search,
                         "verbose|v+" => \$verbose,
                         "absolute!" => \$absolute,
                         "reference-depth|nesting-depth=f",
                           => \$reference_depth,
                         "accessor-depth=f", => \$accessor_depth,
                         "list-depth=n", => \$list_depth,
# This is probably more control than anyone needs
#                        "types-absolute!" => \$types_absolute,
#                        "decls-absolute!" => \$decls_absolute,
#                        "dtrace-absolute!" => \$dtrace_absolute,
                         "perl=s", \$perl,
                         "help|h" => \$do_usage,
                        );

exit(1) unless $parsed;

if ($do_usage) {
    print <<EOM;
This is dfepl, the Daikon front end for Perl. Dfepl is free software;
it may be distributed under the same terms as Daikon itself or under
those of Perl itself. For detailed information, see the Daikon manual,
which appears in the Daikon distribution and also at
http://plse.cs.washington.edu/daikon/.
Options summary:
  --absolute/--noabsolute
  --accessor-depth=NUM
  -A/--accessors-dir=DIRECTORY
  --decls-dir=DIRECTORY
  --decls-style={combined,flat,tree}
  --dtrace-append/--nodtrace-append
  --dtrace-dir=DIRECTORY
  --dtrace-style={combined,flat,tree}
  --help/-h
  --instr-dir=DIRECTORY
  --list-depth=INTEGER
  --output-dir=DIRECTORY
  --perl=PATH
  --nesting-depth=NUMBER
  --types-append/--notypes-append
  -T/--types-dir=DIRECTORY
  --types-file=FILE/-t FILE
  --types-dir=DIRECTORY
  --types-style={combined,flat,tree}
  --verbose/-v
EOM
    exit;
}

if (@types_files or defined($types_search)) {
    $use_types = 1;
} elsif ($use_types) {
    $types_search = "daikon-instrumented";
}

if (defined($accessors_search)) {
    $use_accessors = 1;
} elsif ($use_accessors) {
    $accessors_search = ".";
}

if (not defined($instr_basedir)) {
    if ($use_types) {
        $instr_basedir = "daikon-instrumented";
    } else {
        $instr_basedir = "daikon-untyped";
        if (not defined($types_basedir)) {
            $types_basedir = "daikon-instrumented";
        }
    }
}

$types_basedir = $instr_basedir if not defined($types_basedir);

if (defined($output_dir)) {
    if (defined($decls_basedir) or defined($dtrace_basedir)) {
        die "--output-dir replaces --decls-basedir and --dtrace-basedir";
    } else {
        $decls_basedir = $dtrace_basedir = $output_dir;
    }
} else {
    if (not defined $decls_basedir) {
        $decls_basedir = "daikon-output";
    }
    if (not defined $dtrace_basedir) {
        $dtrace_basedir = "daikon-output";
    }
}

if (defined $absolute) {
    $instr_absolute = $absolute unless defined $instr_absolute;
    $types_absolute = $absolute unless defined $types_absolute;
    $decls_absolute = $absolute unless defined $decls_absolute;
    $dtrace_absolute = $absolute unless defined $dtrace_absolute;
}

$instr_absolute = 0 unless defined $instr_absolute;
$types_absolute = 1 unless defined $types_absolute;
$decls_absolute = 0 unless defined $decls_absolute;
$dtrace_absolute = 0 unless defined $dtrace_absolute;

if ($instr_absolute) {
    $instr_basedir = rel2abs($instr_basedir);
}

if ($types_absolute) {
    $types_basedir = rel2abs($types_basedir);
}

if ($decls_absolute) {
    $decls_basedir = rel2abs($decls_basedir);
}

if ($dtrace_absolute) {
    $dtrace_basedir = rel2abs($dtrace_basedir);
}

if (!defined($types_style) and defined($decls_style)) {
    unless ($decls_style =~ /^tree|flat|combined\z/) {
        die "decls-style should be one of tree, flat, or combined\n";
    }
    $types_style = $decls_style;
} elsif (defined($types_style) and !defined($decls_style)) {
    unless ($types_style =~ /^tree|flat|combined\z/) {
        die "types-style should be one of tree, flat, or combined\n";
    }
    $decls_style = $types_style;
} elsif (!defined($types_style) and !defined($decls_style)) {
    $types_style = $decls_style = "tree";
} elsif ($types_style ne $decls_style) {
    die "Distinct types-style '$types_style' and decls-style '$decls_style' aren't currently supported.";
}

unless ($types_style =~ /^tree|flat|combined\z/) {
    die "types-style should be one of tree, flat, or combined\n";
}

unless ($decls_style =~ /^tree|flat|combined\z/) {
    die "decls-style should be one of tree, flat, or combined\n";
}

unless ($dtrace_style =~ /^tree|flat|combined\z/) {
    die "dtrace-style should be one of tree, flat, or combined\n";
}

if ($reference_depth < 0) {
    die "reference_depth should be non-negative\n";
}

if ($accessor_depth < 0) {
    die "accessor_depth should be non-negative\n";
}

if ($list_depth < 0) {
    die "list_depth should be non-negative\n";
}

if ($verbose) {
    print STDERR "Verbosity level $verbose\n";
    print STDERR "Instrumented sources in $instr_basedir\n";
    print STDERR "Reading types from @types_files\n" if @types_files;
    print STDERR "Looking for types in $types_search\n" if $types_search;
    print STDERR "Looking for accessors in $accessors_search\n"
      if $accessors_search;
}

my $types = "";
for my $tfile (@types_files) {
    if (-e $tfile) {
        $types .= ",-t,$tfile";
    } else {
        warn "Types file $tfile does not exist\n";
    }
}
my $output_opt = ",-O,$types_basedir,$types_style,$types_append";
$output_opt .= ",$dtrace_basedir,$dtrace_style,$dtrace_append";
$output_opt .= ",-D,$reference_depth,$accessor_depth,$list_depth";

my $deparse_opt = "-MO=-qq,DeparseDaikon$types$output_opt";
my $perl_lib = "-I$dirname/front-end/perl/lib";

my $local_types;
my %types_converted;

sub try_local_types {
    my($dir, $fname) = @_;
    print STDERR "Looking for types in $dir/$fname\n" if $verbose;
    if (-e "$dir/$fname") {
        $local_types .= ",-t,$dir/$fname";
        if (not $types_converted{file_id("$dir/$fname")}++) {
            (my $decls_fname = $fname) =~ s/\.types$/.decls/;
            types_to_decls("$dir/$fname", "$decls_basedir/$decls_fname");
        }
    }
}

sub types_to_decls {
    my($types_name, $decls_name) = @_;
    mkpath(dirname $decls_name);
    careful_system($perl, $perl_lib, "-MDaikon::Output",
                   "-e", 'Daikon::Output::types_file_to_decls_file('.
                   '$ARGV[0], $ARGV[1])', $types_name, $decls_name);
}

sub process_file_relative_to {
    my($prog, $dir) = @_;
    my $from;

    my $olddir = undef;
    if ($dir ne ".") {
        $olddir = getcwd();
        chdir($dir);
        print "Changing to directory $dir\n";
        $prog =~ s,\Q$dir\E[/]?,,;
    }

    if (! -d $instr_basedir) {
        mkpath($instr_basedir)
          or die "Can't create directory $instr_basedir: $!\n";
    }

    if (defined($types_search) and ! -d $decls_basedir) {
        mkpath($decls_basedir)
          or die "Can't create directory $decls_basedir: $!\n";
    }

    my $inplace = file_id($instr_basedir) eq file_id(".");
    print STDERR "Annotating in place? ", $inplace ? "yes" : "no", "\n"
      if $verbose;

    if ($inplace) {
        $from = "$prog.uninst";
        if (! -e $from) {
            print STDERR "Renaming $prog to $from\n" if $verbose;
            rename($prog, $from) or die "Can't move $prog to $from: $!\n";
        }
    } else {
        $from = $prog;
    }
    my($bprog, $pack, $combined);
    if ($prog =~ /\.(plx?|t)$/) {
        my $progname = basename($prog, ".plx", ".pl", ".t");
        $combined = "$progname-combined";
        $bprog = "";
        $pack = "$progname-main";
    } else {
        $combined = "combined";
        $bprog = dirname($prog) . "/" . basename($prog, ".pm");
        ($pack = $bprog) =~ s[/][::]g;
        $pack =~ s[\.::][]g;
    }
    $local_types = "";
    if (defined $types_search) {
        try_local_types($types_search, "$combined.types");
        try_local_types($types_search, "$bprog.types") if $bprog ne "";
        try_local_types($types_search, "$pack.types");
        if ($types eq "" and $local_types eq "") {
            die "No type files found for $prog\n";
        }
    }
    my $more_opts = $local_types;
    if (defined $accessors_search) {
        if ($bprog ne "") {
            print STDERR "Looking at $accessors_search/$bprog.accessors\n"
                if $verbose;
            if (-e "$accessors_search/$bprog.accessors") {
                $more_opts .= ",-a,$accessors_search/$bprog.accessors";
            }
        }
        print STDERR "Looking at $accessors_search/$pack.accessors\n"
          if $verbose;
        if (-e "$accessors_search/$pack.accessors") {
            $more_opts .= ",-a,$accessors_search/$pack.accessors";
        }
    }
    my $outfile = "$instr_basedir/$prog";
    my $outpath = dirname($outfile);
    if (not -d $outpath) {
        print STDERR "Making $outpath\n" if $verbose;
        mkpath($outpath, $verbose) or die "Couldn't create $outpath: $!\n";
    } else {
        print STDERR "$outpath exists\n" if $verbose;
    }
    careful_system($perl, $perl_lib, "$deparse_opt,-o,$outfile$more_opts",
                   $from);
    if (defined($olddir)) {
        print "Changing back to $olddir\n";
        chdir($olddir);
    }
}

for my $arg (@ARGV) {
    if (-f $arg) {
        process_file_relative_to($arg, ".");
    } elsif (-d $arg) {
        File::Find::find({wanted => \&is_module}, $arg);
        for my $file (@found_modules) {
            process_file_relative_to($file, $arg);
        }
        @found_modules = ();
    }
}
