The R Project SVN R

Rev

Rev 9783 | Blame | Last modification | View Log | Download | RSS feed 

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

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

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

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

$latex = "@LATEX@";
$make = "@MAKE@";

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

GetOptions (@knownoptions) || usage();

R_version($name, $version) if $opt_version;
usage() if $opt_help;

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 $tmpdir = R_getenv("TMPDIR", "/tmp");
my $R_HOME = $ENV{'R_HOME'} ||
    die "Error: Environment variable R_HOME not found\n";

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();
    $ENV{'R_LIBS'} = "$library:$R_libs";
    chdir($startdir);
}

my $R_opts = "--vanilla";
$R_opts .= " --nsize=$opt_nsize" if $opt_nsize;
$R_opts .= " --vsize=$opt_vsize" if $opt_vsize;

## this is the main loop over all packages that shall be checked
my $pkg;
foreach $pkg (@ARGV){
    my $is_bundle=0;
    $pkg =~ s/\/$//;
    my $pkgname = basename($pkg);
    chdir($startdir);

    my $pkgoutdir="$outdir/$pkgname.Rcheck";
    system("rm -rf $pkgoutdir") if ($opt_clean && (-d $pkgoutdir)) ;
    if(! -d $pkgoutdir){
    if(! mkdir($pkgoutdir, 0755)){
        die("could not create directory $pkgoutdir\n");
        exit(1);
    }
    }

    my $log = new R::Logfile("$pkgoutdir/00check.log");
    $log->message("using log directory $pkgoutdir");

    if(! $opt_library){
    $library = $pkgoutdir;
    $ENV{'R_LIBS'} = "$library:$R_libs";
    }

    print "\n";
    if(system("${R_HOME}/bin/R INSTALL -l $library $pkg")){
    $log->error("installation failed");
    }
    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 updateIndex {

    my ($oldindex, $Rdfiles) = @_;
    my $newindex = "$tmpdir/Rcheck.$$";
    system("${R_HOME}/bin/Rdindex ${Rdfiles} > ${newindex}");
    my $diff = `diff -b $oldindex $newindex`;
    if($diff){
    $log->result("NO");
    if($opt_force){
        $log->message("overwriting \`${oldindex}' as \`--force' was given");
        rename($newindex, $oldindex);
    }
    else{
        $log->message("use \`--force' to overwrite the existing \`${oldindex}'");
    }
    }
    else{
    $log->result("OK");
    }
    unlink $newindex;
}


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 entry");
    if(! $description->{"Package"}){
    $log->error("no DESCRIPTION Package entry found");
    exit(1);
    }
    if($description->{"Package"} ne basename($dir)){
    $log->error("DESCRIPTION Package field differs from dir name");
    exit(1);
    }
    $log->result("OK");
    
    my $entry;
    foreach $entry (qw(Title Version License Author)){
    $log->checking("DESCRIPTION $entry entry");
    if(! $description->{$entry}){
        $log->error("no DESCRIPTION $entry entry found");
        exit(1);
    }
    $log->result("OK");
    }
    

    ## 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 "man"){
    $log->checking("for undocumented objects");
    my @out = split(/\n/,
            `echo \"undoc(dir = \\\"${dir}\\\")\" | \
                         ${R_HOME}/bin/R ${R_opts}`);
    my @err = grep {s/^Error *//} @out;
    @out = grep {/^ *\[/} @out;
    if($#err<0){
        if($#out>=0){
        $log->warning("  " . join("\n  ", @out));
        }
        else{
        $log->result("OK");
        }
    }
    else{
        $log->error("  " . join("\n  ", @err));
        exit(1);
    }
    }

    chdir($pkgoutdir);

    if($opt_examples && (-d "$library/$pkgname/R-ex")){
    $log->creating("${pkgname}-Ex.R");
    if(system("${R_HOME}/bin/massage-Examples ".
          "${pkgname} ${library}/${pkgname}/R-ex/*.R ".
          "> ${pkgname}-Ex.R")){
        $log->error();
        exit(1);
    }
    $log->result("OK");
    $log->checking("examples");
    if(system("${R_HOME}/bin/R BATCH $R_opts ${pkgname}-Ex.R")){
        $log->error("running examples failed");
        exit(1);
    }
    $log->result("OK");
    }

    if($opt_tests && (-d "$startdir/$pkg/tests")){
        my $testdir="$startdir/$pkg/tests";
        $log->checking("tests");
        my $makefiles="-f ${R_HOME}/etc/Makeconf-tests";
        my $makevars="";
        if(-r "$testdir/Makefile"){
            $makefiles .= " -f $testdir/Makefile";
        }
        if(-r "$testdir/Makevars"){
            $makevars = " -f $testdir/Makevars";
        }
        else{
            open makevars, "> Makevars";
            print makevars "makevars = -f Makevars\n";
            print makevars "srcdir = $testdir\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);
        }
        $log->result("OK");
    }
            
        


            
    if($opt_latex && (-d "$library/$pkgname/latex")){
        $ENV{'TEXINPUTS'}="$R_HOME/doc/manual:$ENV{'TEXINPUTS'}";
        $log->creating("${pkgname}-manual.tex");
        open manual, "> ${pkgname}-manual.tex";
        print manual "\\documentclass\{article\}\n" .
            "\\usepackage\{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 $_;
            }
        }
        print manual "\\end\{document\}\n";
        close manual;
        $log->result("OK");
        if(-x $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: $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. All examples provided by the
packages' documentation are tested if they run succesfully. Finally,
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).

If necessary for passing the checks, use the \`--vsize' and \`--nsize'
options to increase R's memory (\`--vanilla' is used by default).

Options:
  -h, --help            print short help message and exit
  -v, --version         print version info and exit

  --vsize=N             set R's vector heap size to N bytes
  --nsize=N             set R's number of cons cells to N
  -l, --library         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)
  --clean --noclean     Clean outdir before using it?

  --examples --noexamples    Run all examples in the Rd files?
  --tests --notests     Run code in tests subdirectory?
  --latex --nolatex     Run latex on help files?

By default, all test sections are turned on.

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