#! @PERL@
#-*- perl -*-

# Copyright (C) 2000 R Development Core Team
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	See the GNU
# General Public License for more details.
#
# A copy of the GNU General Public License is available via WWW at
# http://www.gnu.org/copyleft/gpl.html.	 You can also obtain it by
# writing to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA  02111-1307  USA.

# Send any bug reports to r-bugs@r-project.org

use Cwd;
use File::Basename;
use File::Copy;
use File::Path;
use Getopt::Long;
use R::Dcf;
use R::Utils;

## don't buffer output
$|=1;

my $revision = ' $Revision: 1.27.2.4 $ ';
my $version;
my $name;
$revision =~ / ([\d\.]*) /;
$version = $1;
($name = $0) =~ s|.*/||;

my $LATEX = '@LATEX@';
my $MAKE = '@MAKE@';

$opt_clean = $opt_examples = $opt_tests = $opt_latex = 1;
my @knownoptions = ("help|h", "version|v", "outdir|o:s", "library|l:s",
		    "no-clean", "no-examples", "no-tests", "no-latex");

GetOptions (@knownoptions) || usage();

R_version("R add-on package checker", $version) if $opt_version;
usage() if $opt_help;

$opt_clean = 0 if $opt_no_clean;
$opt_examples = 0 if $opt_no_examples;
$opt_tests = 0 if $opt_no_tests;
$opt_latex = 0 if $opt_no_latex;

my $startdir=getcwd();
$opt_outdir=$startdir unless $opt_outdir;
chdir($opt_outdir) || die "Cannot change to directory $opt_outdir\n";
my $outdir=getcwd();
chdir($startdir);

my $R_HOME = $ENV{'R_HOME'} ||
    die "Error: Environment variable R_HOME not found\n";

my $R_CMD = $ENV{'R_CMD'} ||
    die "Error: Environment variable R_CMD not found\n";

my $WINDOWS = R_getenv("R_UNDER_WINDOWS", 0);
my $TMPDIR = R_getenv("TMPDIR", "/tmp");
my $R_exe = "${R_HOME}/bin/R";
if($WINDOWS){
    $TMPDIR = R_getenv("TMPDIR", "/TEMP");
    die "Please set TMPDIR to a valid temporary directory\n" 
	unless (-d $TMPDIR);
    $R_exe = "Rterm.exe";
    $MAKE = "make";
    $LATEX = "latex";
}

my $R_LIBS = $ENV{'R_LIBS'};
my $library;
if($opt_library){
    chdir($opt_library) ||
	die "Error: cannot change to directory \`$opt_library'\n";
    $library=getcwd();
    if($WINDOWS){
	$ENV{'R_LIBS'} = "$library;$R_LIBS";
    }
    else{
	$ENV{'R_LIBS'} = "$library:$R_LIBS";
    }
	
    chdir($startdir);
}

my $R_opts = "--vanilla";

if($opt_latex){
    my $log = new R::Logfile();
    $log->checking("for working latex");
    open(texfile, "> $TMPDIR/Rtextest$$.tex") ||
	die "cannot write to Rtextest$$.tex\n";
    print texfile "\\documentclass\{article\}\\begin\{document\}" .
	"test\\end\{document\}\n";
    close texfile;
    chdir($TMPDIR);
    if(system("$LATEX Rtextest$$ > Rtextest$$.out")){
	$log->result("NO");
	$HAVE_LATEX=0;
    }
    else{
	$log->result("OK");
	$HAVE_LATEX=1;
    }
    unlink(<Rtextest$$.*>);
    chdir($startdir);
    $log->close();
}


## this is the main loop over all packages to be checked
my $pkg;
$#ARGV >=0 || die "no packages were specified";
foreach $pkg (@ARGV){
    my $is_bundle=0;
    $pkg =~ s/\/$//;
    my $pkgname = basename($pkg);
    chdir($startdir);

    (-d $pkg) || die "\`$pkg' is not a directory";
    
    my $pkgoutdir="$outdir/$pkgname.Rcheck";
    rmtree($pkgoutdir) if ($opt_clean && (-d $pkgoutdir)) ;
    if(! -d $pkgoutdir){
	if(! mkdir($pkgoutdir, 0755)){
	    die("could not create directory $pkgoutdir\n");
	    exit(1);
	}
    }
    
    $log = new R::Logfile("$pkgoutdir/00check.log");
    $log->message("using log directory $pkgoutdir");
    
    if(! $opt_library){
	$library = $pkgoutdir;
	if($WINDOWS){
	    $ENV{'R_LIBS'} = "$library;$R_LIBS";
	}
	else{
	    $ENV{'R_LIBS'} = "$library:$R_LIBS";
	}
    }
    
    print "\n";
    if(system("${R_CMD} INSTALL -l $library $pkg")){
	$log->error("installation failed");
	exit(1);
    }
    print("\n");
    
    my $description;
    $log->checking("for file \`$pkg/DESCRIPTION'");
    if(-r "$pkg/DESCRIPTION"){
	$description = new R::Dcf("$pkg/DESCRIPTION");
	$log->result("OK");
    }
    else{
	$log->result("NO");
	exit(1);
    }
    
    if($description->{"Contains"}){
	$log->message("Looks like \`${pkg}' is a package bundle");
	$is_bundle=1;
	my @bundlepkgs = split(/\s+/, $description->{"Contains"});
	my $ppkg="";
	foreach $ppkg (@bundlepkgs){
	    $log->message("checking \`$ppkg' in bundle \`$pkg'");
	    $log->setstars("**");
	    chdir($startdir);
	    check_pkg("$pkg/$ppkg", $pkgoutdir, $startdir, $library,
		      $is_bundle, $description, $log);
	    $log->setstars("*");
	}
    }
    else{
	$is_bundle=0;
	chdir($startdir);
	check_pkg("$pkg", $pkgoutdir, $startdir, $library,
		  $is_bundle, $description, $log);
    }
    
    if($log->{"warnings"}){
	print("\n") ;
	$log->summary();
    }
    $log->close();
    print("\n");
}

#**********************************************************

sub check_pkg {

    my ($pkg, $pkgoutdir, $startdir, $library,
	$in_bundle, $description, $log) = @_;

    my $pkgname = basename($pkg);

    $log->checking("package directory");
    my $dir;
    if(-d $pkg){
	chdir($pkg);
	$dir = getcwd();
    }
    else{
	$log->error("package dir \`${pkg}' does not exist");
	exit 1;
    }
    $log->result("OK");
    
    if($in_bundle){  # join DESCRIPTION and DESCRIPTION.in
	if(-r "DESCRIPTION.in"){
	    $log->checking("for file \`DESCRIPTION.in'");
	    my $description_in = new R::Dcf("DESCRIPTION.in");
	    my $key;
	    foreach $key (keys(%$description)){
		$description_in->{$key}=$description->{$key};
	    }
	    ## from now on use $description_in instead of $description
	    ## in this subroutine
	    $description = $description_in;
	    $log->result("OK");
	    $log->message("joining DESCRIPTION and DESCRIPTION.in");
	}
	else{
	    $log->result("NO");
	    exit(1);
	}
	
    }

    ## mandatory entries in DESCRIPTION:
    ##   Package, Title, Version, License, Author
    $log->checking("DESCRIPTION Package field");
    if(! $description->{"Package"}){
	$log->error("no DESCRIPTION Package field found");
	exit(1);
    }
    if($description->{"Package"} ne basename($dir)){
	$log->error("DESCRIPTION Package field differs from dir name");
	exit(1);
    }
    $log->result("OK");
    
    $log->checking("DESCRIPTION Version field");
    if(! $description->{"Version"}){
	$log->error("no DESCRIPTION Version field found");
	exit(1);
    }
    if($description->{"Version"} =~ /[^\d\.\-]/){
	$log->error("Version may only contain digits, \`.' and \`-'");
	exit(1);
    }
    $log->result("OK");
    
    my $field;
    foreach $field (qw(Title License Author)){
	$log->checking("DESCRIPTION $field field");
	if(! $description->{$field}){
	    $log->error("no DESCRIPTION $field field found");
	    exit(1);
	}
	$log->result("OK");
    }
    ## FIXME:
    ## Currently only give warning about missing `Maintainer' field.
    ## Should be required in 1.3.0.
    ## Also add check whether the field gives ONE email address only.
    $log->checking("DESCRIPTION Maintainer field");
    if(!$description->{"Maintainer"}) {
	$log->warning();
	$log->message("  no DESCRIPTION Maintainer field found");
    }
    else {
	$log->result("OK");
    }
    ## </FIXME>
    
    ## check Rd documentation files
    
    if(-d "man"){
	$log->checking("Rd files");
	my @rdfiles;
	my @badfiles;
	while(<man/*.[rR]d>){
	    if(/</){
		push @badfiles, $_;
	    }
	    else{
		push @rdfiles, $_;
	    }
	}
	if($#badfiles>=0){
	    $log->error("  Cannot handle Rd file names containing \`<'.\n" .
			"  These are not legal file names on all R platforms.\n" .
			"  Please rename the following files and try again:");
	    $log->message("    " . join("\n    ", @badfiles));
	    exit(1);
	}
	
	@rdfiles = sort(@rdfiles);
	my $file;
	my @mandatoryTags = qw(name alias title description keyword);
	my @uniqueTags = qw(name title description usage arguments
			    format details value references source
			    seealso examples note author synopsis);
	my %badmandatory;
	my %badunique;
	
	## create hash allTags with all tags found in mandatory Tags and
	## uniqueTags 
	my $tag;
	my %allTags;
	foreach $tag (@mandatoryTags, @uniqueTags){
	    $allTags{$tag}++;
	}
	
	foreach $rdfile (@rdfiles){
	    open rdfile, "< $rdfile" ||
		die "cannot open \`$rdfile' for reading\n";
	    
	    my %tagcount;
	    while(<rdfile>){
		my $line = $_;
		foreach $tag (keys %allTags) {
		    if($line=~/^\s*\\$tag/){
			$tagcount{$tag}++;
		    }
		}
	    }
	    close rdfile;
	    
	    foreach $tag (@mandatoryTags){
		push(@{$badmandatory{$tag}}, $rdfile)
		    unless $tagcount{$tag}>0;
	    }
	    foreach $tag (@uniqueTags){
		push(@{$badunique{$tag}}, $rdfile)
		    unless $tagcount{$tag}<=1;
	    }
	}

	my $any=0;
	foreach $tag (@mandatoryTags){
	    if(exists $badmandatory{$tag}){
		$log->warning("") unless $any;
		$any++;
		$log->message("  Rd files without \`${tag}':");
		$log->message("    " .
			      join("\n    ", @{$badmandatory{$tag}}));
	    }
	}
	foreach $tag (@uniqueTags){
	    if(exists $badunique{$tag}){
		$log->warning("") unless $any;
		$any++;
		$log->message("  Rd files with duplicate \`${tag}':");
		$log->message("    " .
			      join("\n    ", @{$badunique{$tag}}));
	    }
	}

	$log->result("OK") unless $any;
    }

    ## Check for undocumented objects

    if(((-d "R") || (-d "data")) && -d "man") {
	$log->checking("for undocumented objects");

	my $Rcmd = "$TMPDIR/Rcmd.$$";
	my $Rout = "$TMPDIR/Rout.$$";
	open Rcmd, "> $Rcmd" || die "Cannot write to \`$Rcmd'\n";
        print Rcmd "undoc(dir = \"${dir}\")\n";
        close Rcmd;
        system("${R_exe} ${R_opts} < ${Rcmd} > ${Rout}");
        my @out;
        open Rout,  "< $Rout";
        while (<Rout>) {chomp; push(@out, $_);}
        close Rout;
        unlink($Rcmd);
        unlink($Rout);

	my @err = grep {s/^Error *//} @out;
	@out = grep {/^ *\[/} @out;
	if($#err<0){
	    if($#out>=0){
		$log->warning();
                $log->print(join("\n", @out) . "\n");
	    }
	    else{
		$log->result("OK");
	    }
	}
	else{
	    $log->error("  " . join("\n ", @err));
	    exit(1);
	}
    }

    chdir($pkgoutdir);

    if($opt_examples && <$library/$pkgname/R-ex/*.R>) {
	$log->creating("${pkgname}-Ex.R");
        my $iszipped = 0;
        my $massage = "massage-Examples";
        $massage .= ".sh" if($WINDOWS);
        if(-e "${library}/${pkgname}/R-ex/R-ex.zip") {
            $iszipped = 1;
            system("unzip ${library}/${pkgname}/R-ex/R-ex.zip " .
                   "-d ${library}/${pkgname}/R-ex");
        }
  	if(system("${R_CMD} ${massage} ".
  		  "${pkgname} ${library}/${pkgname}/R-ex/*.R ".
  		  "> ${pkgname}-Ex.R")){
  	    $log->error();
  	    exit(1);
  	}
        if($iszipped) {
            unlink(<${library}/${pkgname}/R-ex/*.R>);
        }

	$log->result("OK");
	$log->checking("examples");
	if(system("${R_exe} ${R_opts} " .
                  "< ${pkgname}-Ex.R > ${pkgname}-Ex.Rout")){
	    $log->error("running examples failed");
	    exit(1);
	}
	$log->result("OK");
    }

    if($opt_tests && (-d "$startdir/$pkgname/tests")){
        $log->checking("tests");
        my $testsrcdir="$startdir/$pkgname/tests";
        my $testdir="$pkgoutdir/tests";
        if(! -d $testdir){
            if(! mkdir($testdir, 0755)){
	        die("could not create directory $testdir\n");
	        exit(1);
	    }
        }
        chdir($testdir);
        while(<$testsrcdir/*>){
            copy($_, basename($_));
        }
        my $makefiles="-f ${R_HOME}/etc/Makeconf-tests";
        my $makevars="";
        if($WINDOWS && (-r "$testsrcdir/Makefile.win")){
            $makefiles .= " -f $testsrcdir/Makefile.win";
        }
        elsif(-r "$testsrcdir/Makefile"){
            $makefiles .= " -f $testsrcdir/Makefile";
        }
        if($WINDOWS && (-r "$testsrcdir/Makevars.win")){
            $makevars = " -f $testsrcdir/Makevars.win";
        }
        elsif(-r "$testsrcdir/Makevars"){
            $makevars = " -f $testsrcdir/Makevars";
        }
        else{
            open makevars, "> Makevars";
            print makevars "makevars = -f Makevars\n";
            print makevars "srcdir = $testsrcdir\n";
            ## at least windows does not pass env correctly to make
            print makevars "R_LIBS = $ENV{'R_LIBS'}\n"; 
            print makevars "VPATH = \$(srcdir)\n\n";
            print makevars "test-src-1=";
            while(<$testdir/*.R>){
                print makevars "\\\n " . basename($_);
            }
            print makevars "\n";
            print makevars "test-src-auto=";
            while(<$testdir/*.Rin>){
                s/Rin$/R/;
                print makevars "\\\n " . basename($_);
            }
            print makevars "\n";
            close makevars;
            $makevars = " -f Makevars";
        }
        print "\n";
        if(system("$MAKE $makefiles $makevars")){
            $log->error();
            exit(1);
        }
        chdir($pkgoutdir);
        $log->result("OK");
    }
            
    if($opt_latex && (-d "$library/$pkgname/latex")){
        if($WINDOWS){
            $ENV{'TEXINPUTS'}="$R_HOME/doc/manual;$ENV{'TEXINPUTS'}";
        }
        else{
            $ENV{'TEXINPUTS'}="$R_HOME/doc/manual:$ENV{'TEXINPUTS'}";
        }
        $log->creating("${pkgname}-manual.tex");
        open manual, "> ${pkgname}-manual.tex";
        print manual "\\documentclass\{article\}\n" .
            "\\usepackage[ae, hyper]\{Rd\}\n".
                "\\begin\{document\}\n";
        while(<$library/$pkgname/latex/*.tex>){
            my $file=$_;
            open file, "< $file" ||
                $log->error("cannot open file \`$file' for reading");
            while(<file>){
                print manual $_;
            }
            close file;
        }
        print manual "\\end\{document\}\n";
        close manual;
        $log->result("OK");
        if($HAVE_LATEX){
            $log->checking("${pkgname}-manual.tex");
            print "\n";
            if(system("$LATEX ${pkgname}-manual")){
                $log->error();
                exit(1);
            }
            $log->result("OK");
        }
    }
}
            

#**********************************************************

sub usage {
    print STDERR <<END;
Usage: R CMD $name [options] pkgdirs

Check R packages from package sources in the directories specified by
pkgdirs.  A variety of diagnostic checks on directory structure, index
and control files are performed.  The package is installed into the log
directory (which includes the translation of all Rd files into several
formats), and the Rd files are tested by LaTeX (if available).  All
examples and tests provided by the package are tested if they run
succesfully.

Options:
  -h, --help            print short help message and exit
  -v, --version         print version info and exit
  -l, --library=LIB     library directory used for test installation
                        of packages (default is outdir)
  -o, --outdir=DIR      directory used for logfiles, R output, etc.
                        (default is \`pkg.Rcheck\' in current directory,
			where \`pkg\' is the name of the package checked)
      --no-clean        Do not clean outdir before using it
      --no-examples     Do not run the examples in the Rd files
      --no-tests        Do not run code in tests subdirectory
      --no-latex        Do not run LaTeX on help files

By default, all test sections are turned on.

Email bug reports to <r-bugs\@r-project.org>.
END
    exit 0;
}