#! @PERL@
#-*- perl -*-
# Copyright (C) 2000, 2001 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
## <FIXME>
## This is not portable: has Unix-style file paths and system().
## </FIXME>
use Cwd;
use File::Basename;
use File::Copy;
use File::Find;
use File::Path;
use Getopt::Long;
use R::Dcf;
use R::Rdtools;
use R::Utils;
use Text::DelimMatch;
## don't buffer output
$| = 1;
my $revision = ' $Revision: 1.81 $ ';
my $version;
my $name;
$revision =~ / ([\d\.]*) /;
$version = $1;
($name = $0) =~ s|.*/||;
my $LATEX = '@LATEX@';
my $MAKE = '@MAKE@';
## Options
my $opt_clean = 1;
my $opt_examples = 1;
my $opt_tests = 1;
my $opt_latex = 1;
my $opt_use_gct = 0;
my $opt_codoc = 1;
my $opt_perms = 1;
my $opt_install = 1;
my @knownoptions = ("help|h", "version|v", "outdir|o:s", "library|l:s",
"no-clean", "no-examples", "no-tests", "no-latex",
"use-gct" => \$opt_use_gct, "no-codoc", "no-perms",
"no-install");
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;
$opt_codoc = 0 if $opt_no_codoc;
$opt_perms = 0 if $opt_no_perms;
$opt_install = 0 if $opt_no_install;
sub env_path {
my @args = @_;
my $envsep = ":";
$envsep = ";" if($WINDOWS);
join($envsep, @args);
}
my $startdir = cwd();
$opt_outdir = $startdir unless $opt_outdir;
chdir($opt_outdir) ||
die "Error: cannot change to directory \`$opt_outdir'\n";
my $outdir = cwd();
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";
## <FIXME>
## Currently, R_OSTYPE is always set on Unix/Windows.
my $OS = R_getenv("R_OSTYPE", "mac");
## </FIXME>
my $R_exe = "${R_HOME}/bin/R";
my $TMPDIR = R_getenv("TMPDIR", "/tmp");
$WINDOWS = ($OS eq "windows");
if($WINDOWS) {
$TMPDIR = R_getenv("TMPDIR", "/TEMP");
die "Please set TMPDIR to a valid temporary directory\n"
unless (-e $TMPDIR);
$R_exe = "Rterm.exe";
$LATEX = "latex";
$MAKE = "make";
}
my $cfile = "$TMPDIR/Rcheck.$$";
my $R_LIBS = $ENV{'R_LIBS'};
my $library;
if($opt_library) {
chdir($opt_library) ||
die "Error: cannot change to directory \`$opt_library'\n";
$library = cwd();
$ENV{'R_LIBS'} = env_path($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")
or die "Error: cannot write to Rtextest$$.tex\n";
print TEXFILE "\\documentclass\{article\}\\begin\{document\}" .
"test\\end\{document\}\n";
close TEXFILE;
chdir($TMPDIR);
if(Rsystem("$LATEX Rtextest$$ > Rtextest$$.out")) {
$log->result("NO");
$HAVE_LATEX = 0;
} else {
$log->result("OK");
$HAVE_LATEX = 1;
}
unlink(<Rtextest$$.*>);
chdir($startdir);
$log->close();
}
## get the valid keywords for later ...
my %standard_keywords = ();
open(KEYWORDS, "< ${R_HOME}/doc/KEYWORDS.db")
or die "Error: cannot open \`KEYWORDS.db'";
while(<KEYWORDS>) {
if(/^.*\|([^:]*):.*/) {
$standard_keywords{$1} = 1;
}
}
close KEYWORDS;
## this is the main loop over all packages to be checked
$#ARGV >= 0 or die "Error: no packages were specified";
foreach my $pkg (@ARGV) {
## $pkg should be the path to the package (bundle) root source
## directory, either absolute or relative to $startdir.
## $pkgdir is the corresponding absolute path.
## $pkgname is the name of the package (bundle).
chdir($startdir);
$pkg =~ s/\/$//;
(-d $pkg) || die "Error: package dir \`$pkg' does not exist";
chdir($pkg) ||
die "Error: cannot change to directory \`$pkg'\n";
my $pkgdir = cwd();
my $pkgname = basename($pkgdir);
chdir($startdir);
my $pkgoutdir = "$outdir/$pkgname.Rcheck";
rmtree($pkgoutdir) if ($opt_clean && (-d $pkgoutdir)) ;
if(! -d $pkgoutdir) {
if(! mkdir($pkgoutdir, 0755)) {
die("Error: cannot create directory \`$pkgoutdir'\n");
exit(1);
}
}
$log = new R::Logfile("$pkgoutdir/00check.log");
$log->message("using log directory \`$pkgoutdir'");
if(! $opt_library) {
$library = $pkgoutdir;
$ENV{'R_LIBS'} = env_path($library, $R_LIBS);
}
my $description;
my $is_base_pkg = 0;
## Package sources from the R distribution are special. They have a
## `DESCRIPTION.in' file (instead of `DESCRIPTION'), with Version
## field containing `@VERSION@' for substitution by configure. We
## test for such packages by looking for `DESCRIPTION.in' with
## Priority `base', and skip the installation test for such
## packages.
if(-r "$pkgdir/DESCRIPTION.in") {
$description = new R::Dcf("$pkgdir/DESCRIPTION.in");
if($description->{"Priority"} eq "base") {
$log->message("looks like \`${pkgname}' is a base package");
$log->message("skipping installation test");
$is_base_pkg = 1;
}
}
if(!$is_base_pkg) {
if($opt_install) {
print("\n");
if(system("${R_CMD} INSTALL -l $library $pkgdir")) {
$log->error("installation failed");
exit(1);
}
print("\n");
}
$log->checking("for file \`$pkgname/DESCRIPTION'");
if(-r "$pkgdir/DESCRIPTION") {
$description = new R::Dcf("$pkgdir/DESCRIPTION");
$log->result("OK");
}
else {
$log->result("NO");
exit(1);
}
}
my $is_bundle = 0;
if($description->{"Contains"}) {
$log->message("looks like \`${pkgname}' is a package bundle");
$is_bundle = 1;
my @bundlepkgs = split(/\s+/, $description->{"Contains"});
foreach my $ppkg (@bundlepkgs) {
$log->message("checking \`$ppkg' in bundle \`$pkgname'");
$log->setstars("**");
chdir($startdir);
check_pkg("$pkgdir/$ppkg", $pkgoutdir, $startdir, $library,
$is_bundle, $description, $log, $is_base_pkg);
$log->setstars("*");
}
}
else {
$is_bundle = 0;
chdir($startdir);
check_pkg($pkgdir, $pkgoutdir, $startdir, $library,
$is_bundle, $description, $log, $is_base_pkg);
}
if($log->{"warnings"}) {
print("\n") ;
$log->summary();
}
$log->close();
print("\n");
}
#**********************************************************
sub check_pkg {
my ($pkg, $pkgoutdir, $startdir, $library,
$in_bundle, $description, $log, $is_base_pkg) = @_;
my ($pkgdir, $pkgname);
## $pkg is the argument we received from the main loop.
## $pkgdir is the corresponding absolute path,
## $pkgname the name of the package.
## Note that we need to do repeat the checking from the main loop in
## the case of package bundles (and we could check for this).
$log->checking("package directory");
chdir($startdir);
$pkg =~ s/\/$//;
if(-d $pkg) {
chdir($pkg) ||
die "Error: cannot change to directory \`$pkg'\n";
$pkgdir = cwd();
$pkgname = basename($pkgdir);
}
else {
$log->error("Error: package dir \`$pkg' does not exist");
exit 1;
}
$log->result("OK");
chdir($pkgdir);
## Check for sufficient file permissions (Unix only).
## This is a bit controversial, and hence has an option `--no-perms'
## to turn this off. In fact, the code below does a bit too much.
## What would really be needed is the following:
## * All dirs or files must be at least 555 or 444, respectively.
## * Everything that gets installed must be writeable. This
## includes DESCRIPTION COPYING INDEX TITLE data/* demo/* exec/*
## and inst/*.
## * All directories used for building `objects' must be at least
## 755. This includes `.' and src.
## Given time, the above could be implemented.
if($opt_perms && ($OS eq "unix")) {
$log->checking("for sufficient/correct file permissions");
my @badfiles = ();
my @excludepatterns = ("^.Rbuildignore\$", "\~\$", "\\.swp\$",
"^.*/\\.#[^/]*\$", "^.*/#[^/]*#\$");
if(-f "./.Rbuildignore") {
open(RBUILDIGNORE, "./.Rbuildignore");
while(<RBUILDIGNORE>) {
chop;
push(@excludepatterns, $_) if $_;
}
close(RBUILDIGNORE);
}
## Phase A. Directories at least 755, files at least 644.
sub findWrongPermsA {
my $filename = $File::Find::name;
$filename =~ s/^[^\/]*\///;
foreach my $p (@excludepatterns) {
return 0 if($filename =~ /$p/);
}
if(-d $_ && (((stat $_)[2] & 00755) < oct("755"))) {
push @badfiles, $File::Find::name;
}
if(-f $_ && (((stat $_)[2] & 00644) < oct("644"))) {
push @badfiles, $File::Find::name;
}
}
find(\&findWrongPermsA, ".");
if($#badfiles >= 0) {
$log->error(" Found the following files with " .
"insufficient permissions:");
$log->message(" " . join("\n ", @badfiles));
$log->message(" Please fix permissions and try again.");
exit(1);
}
## Phase B. Text files (as determined by their extensions)
## should really be mode 644.
@badfiles = ();
my @textfile_patterns =
("\\.[RSdqr]\$", # R source code
"\\.[Rr]d\$", # Rd files
"\\.([Ccfh]|cc|cpp)\$",
# C/C++/FORTRAN sources and headers
"^(DESCRIPTION|INDEX|README|TITLE)\$");
sub findWrongPermsB {
my $filename = $File::Find::name;
$filename =~ s/^[^\/]*\///;
foreach my $p (@excludepatterns) {
return 0 if($filename =~ /$p/);
}
if(-f $_ && (((stat $_)[2] & 00777) != oct("644"))) {
foreach my $p (@textfile_patterns) {
if($filename =~ /$p/) {
push @badfiles, $File::Find::name;
last;
}
}
}
}
find(\&findWrongPermsB, ".");
if($#badfiles >= 0) {
$log->warning(" Found the following text files with " .
"incorrect permissions:");
$log->message(" " . join("\n ", @badfiles));
$log->message(" Please fix permissions.");
}
else {
$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");
foreach my $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);
}
}
## Check mandatory entries in DESCRIPTION:
## Package, Version, License, Description, Title, Author,
## Maintainer.
$log->checking("DESCRIPTION Package field");
if(! $description->{"Package"}) {
$log->error("no DESCRIPTION Package field found");
exit(1);
}
my $tmp = $description->{"Package"};
if($description->{"Package"} ne $pkgname) {
$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\.\-]/) && !$is_base_pkg) {
## Package sources from the R distribution have `@VERSION@' in
## their `DESCRIPTION.in' files ...
$log->error("Version may only contain digits, \`.' and \`-'");
exit(1);
}
$log->result("OK");
foreach my $field (qw(License Description Title Author)) {
$log->checking("DESCRIPTION $field field");
if(! $description->{$field}) {
$log->error("no DESCRIPTION $field field found");
exit(1);
}
$log->result("OK");
}
$log->checking("DESCRIPTION Maintainer field");
if(!$description->{"Maintainer"}) {
$log->error("no DESCRIPTION Maintainer field found");
exit(1);
}
elsif($description->{"Maintainer"} !~ /^[^<>]*<[^<>]+> *$/) {
$log->warning();
$log->message(" malformed Maintainer field");
}
else {
$log->result("OK");
}
if($description->{"Depends"}) {
$log->checking("DESCRIPTION Depends field");
my @dependencies = split(/\,/, $description->{"Depends"});
my $any = 0;
foreach my $dep (@dependencies) {
$dep =~ /^\s*(\w+)(\s*\(([^) ]+)\s+([^) ]+)\))?\s*$/;
## The entry is malformed if there is no match, or there is
## a match but the dep_op is different from `<=' or `>', or
## the dep_version does not only consist of digits, `.' or
## `-'.
if(!($1) || ($2 && (!(($3 eq "<=") || ($3 eq ">="))
|| ($4 =~ /[^\d\.\-]/)))) {
$any++;
break;
}
}
if($any == 0) {
$log->result("OK")
}
else {
$log->warning();
$log->message(" malformed Depends field");
}
}
## Check R code for syntax errors.
if(!$is_base_pkg && -d "R") {
$log->checking("R files for syntax errors");
my @Rfiles = &list_files_with_exts("R", "[RrSsq]");
my $Rcmd = "$TMPDIR/Rcmd.$$";
my $Rout = "$TMPDIR/Rout.$$";
open RCMD, "> $Rcmd" or die "Error: cannot write to \`$Rcmd'\n";
print RCMD "Rfiles <- c(\"", join("\", \"", @Rfiles), "\")\n";
print RCMD "for(f in Rfiles)\n";
print RCMD "if(inherits(try(parse(f)), \"try-error\")) stop(f)\n";
close RCMD;
Rsystem("${R_exe} ${R_opts} --quiet < ${Rcmd} > ${Rout}");
my @out;
open ROUT, "< $Rout";
while(<ROUT>) {chomp; push(@out, $_);}
close ROUT;
unlink($Rcmd);
unlink($Rout);
@out = grep(/^Error:/, @out);
if($#out >= 0) {
my $Rfile = $out[0];
$Rfile =~ s/^Error: *//;
$log->error(" Syntax error in file " . $Rfile);
exit(1);
}
else {
$log->result("OK");
}
}
## Check usage of library.dynam (if any).
if(!$is_base_pkg && -d "R") {
$log->checking("R files for library.dynam");
my @Rfiles;
if($opt_install) {
## Only need to check the installed file (if installed).
@Rfiles = ("$library/$pkgname/R/$pkgname");
}
else {
## Otherwise (if the package was not installed), we need to
## check all R code files.
@Rfiles = &list_files_with_exts("R", "[RrSsq]");
}
my $any = 0;
my $ext;
foreach my $Rfile (@Rfiles) {
last if $any;
open(RFILE, "< $Rfile")
or die "Error: cannot open file \`$Rfile' for reading";
while(<RFILE>) {
if(/library.dynam\(\"(.*?)\"/o) {
my $arg = $1;
if($arg =~ /\.(so|sl|dll)$/) {
$ext = $1;
$any++;
last;
}
}
}
close(RFILE);
}
if($any == 0) {
$log->result("OK");
}
else {
$log->error(" library.dynam used with extension \`.$ext'");
exit(1);
}
}
## Check whether methods have all arguments of the corresponding
## generic.
if(-d "R") {
$log->checking("generic/method consistency");
my $Rcmd = "$TMPDIR/Rcmd.$$";
my $Rout = "$TMPDIR/Rout.$$";
open RCMD, "> $Rcmd" or die "Error: cannot write to \`$Rcmd'\n";
print RCMD "library(tools)\n";
if($opt_install && ($OS eq "unix")) {
print RCMD "checkMethods(package = \"${pkgname}\")\n";
}
else {
print RCMD "checkMethods(dir = \"${pkgdir}\")\n";
}
close RCMD;
Rsystem("${R_exe} ${R_opts} --quiet < ${Rcmd} > ${Rout}");
my @out;
open ROUT, "< $Rout";
while(<ROUT>) {chomp; push(@out, $_);}
close ROUT;
unlink($Rcmd);
unlink($Rout);
@out = grep(!/^\>/, @out);
if($#out>=0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
}
## Check whether assignment functions have their final argument
## named `value'.
if(-d "R") {
$log->checking("for assignment functions with final arg not " .
"named \`value'");
my $Rcmd = "$TMPDIR/Rcmd.$$";
my $Rout = "$TMPDIR/Rout.$$";
open RCMD, "> $Rcmd" or die "Error: cannot write to \`$Rcmd'\n";
print RCMD "library(tools)\n";
if($opt_install && ($OS eq "unix")) {
print RCMD "checkAssignFuns(package = \"${pkgname}\")\n";
}
else {
print RCMD "checkAssignFuns(dir = \"${pkgdir}\")\n";
}
close RCMD;
Rsystem("${R_exe} ${R_opts} --quiet < ${Rcmd} > ${Rout}");
my @out;
open ROUT, "< $Rout";
while(<ROUT>) {chomp; push(@out, $_);}
close ROUT;
unlink($Rcmd);
unlink($Rout);
@out = grep(!/^(\>|character)/, @out);
if($#out>=0) {
## <FIXME>
## Change back from warning() to error() and exit when we
## have output from loading packages under control.
$log->warning();
$log->print(join("\n", @out) . "\n");
## exit(1);
## </FIXME>
}
else {
$log->result("OK");
}
}
## Check R documentation files.
if(-d "man") {
$log->checking("Rd files");
my @rdfiles = &list_files_with_exts("man", "[Rr]d");
my $manOSdir = &file_path("man", $OS);
if(-d $manOSdir) {
@rdfiles = (@rdfiles,
&list_files_with_exts($manOSdir, "[Rr]d"));
}
my @badfiles = grep(/</, @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 @badbraces;
my %badmandatory;
my %badunique;
my %badkeywords;
## create hash allTags with all tags found in mandatory Tags and
## uniqueTags
my %allTags;
foreach my $tag (@mandatoryTags, @uniqueTags) {
$allTags{$tag}++;
}
foreach my $rdfile (@rdfiles) {
open(RDFILE, "< $rdfile")
or die "Error: cannot open \`$rdfile' for reading\n";
my %keywords;
my %tagcount;
while(<RDFILE>) {
my $line = $_;
foreach my $tag (keys %allTags) {
if($line =~ /^\s*\\$tag/) {
$tagcount{$tag}++;
}
}
if($line =~ /^\s*\\keyword{\s*([^}]*[^}\s])\s*}.*/) {
$keywords{$1} = 1;
}
}
close RDFILE;
foreach my $tag (@mandatoryTags) {
push(@{$badmandatory{$tag}}, $rdfile)
unless $tagcount{$tag}>0;
}
foreach my $tag (@uniqueTags) {
push(@{$badunique{$tag}}, $rdfile)
unless $tagcount{$tag}<=1;
}
foreach my $key (keys(%keywords)) {
push(@{$badkeywords{$rdfile}}, $key)
unless $standard_keywords{$key};
}
## Check for unbalanced braces.
my $text = "";
## Read the Rd file via Rdpp, and get rid of the \alias
## entries as these may have unbalanced braces (Paren.Rd).
my @lines = split(/\n/, &Rdpp($rdfile, $OS));
foreach my $line (@lines) {
$text .= "\n$line" unless ($line =~ /^\\alias/);
}
$text .= "\n";
my $dc = new Text::DelimMatch;
$dc->delim("\{", "\}");
$dc->escape("\\");
$text =~ s/([^\\])%.*\n/$1\n/g; # ???
## Now loop through matching pairs of braces.
while($dc->match($text)) {
$text = $dc->post_matched;
}
## Get rid of trailing comments.
$text =~ s/^%.*\n/\n/gs;
$text =~ s/\n%.*\n/\n/gs;
## Anything left in $text means unbalanced.
if(!($text =~ /^\s*$/)) {
push(@badbraces, $rdfile);
}
}
my $any = 0;
if($#badbraces >= 0) {
$log->warning("") unless $any;
$any++;
$log->message(" Rd files with unbalanced braces:");
$log->message(" " . join("\n ", @badbraces));
}
foreach my $tag (@mandatoryTags) {
if(exists $badmandatory{$tag}) {
$log->warning("") unless $any;
$any++;
$log->message(" Rd files without \`${tag}':");
$log->message(" " .
join("\n ", @{$badmandatory{$tag}}));
}
}
foreach my $tag (@uniqueTags) {
if(exists $badunique{$tag}) {
$log->warning("") unless $any;
$any++;
$log->message(" Rd files with duplicate \`${tag}':");
$log->message(" " .
join("\n ", @{$badunique{$tag}}));
}
}
if(keys(%badkeywords)) {
$log->warning("") unless $any;
$any++;
foreach my $file (keys(%badkeywords)) {
$log->message(" non-standard keyword(s) in \`$file': " .
join(" ", @{$badkeywords{$file}}));
}
}
$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" or die "Error: cannot write to \`$Rcmd'\n";
print RCMD "library(tools)\n";
if($opt_install && ($OS eq "unix")) {
print RCMD "undoc(package = \"${pkgname}\")\n";
}
else {
print RCMD "undoc(dir = \"${pkgdir}\")\n";
}
close RCMD;
Rsystem("${R_exe} ${R_opts} --quiet < ${Rcmd} > ${Rout}");
my @out;
open ROUT, "< $Rout";
while(<ROUT>) {chomp; push(@out, $_);}
close ROUT;
unlink($Rcmd);
unlink($Rout);
my @err = grep(/^Error/, @out);
@out = grep(!/^(\>|character)/, @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);
}
}
## Check for code/documentation mismatches.
if($opt_codoc && ((-d "R") || (-d "data")) && -d "man") {
$log->checking("for code/documentation mismatches");
my $Rcmd = "$TMPDIR/Rcmd.$$";
my $Rout = "$TMPDIR/Rout.$$";
open RCMD, "> $Rcmd" or die "Error: cannot write to \`$Rcmd'\n";
print RCMD "library(tools)\n";
if($opt_install && ($OS eq "unix")) {
print RCMD "codoc(package = \"${pkgname}\")\n";
}
else {
print RCMD "codoc(dir = \"${pkgdir}\")\n";
}
close RCMD;
Rsystem("${R_exe} ${R_opts} --quiet < ${Rcmd} > ${Rout}");
my @out;
open ROUT, "< $Rout";
while(<ROUT>) {chomp; push(@out, $_);}
close ROUT;
unlink($Rcmd);
unlink($Rout);
## <FIXME>
## With the current heuristics codoc() may throw an error even
## though the documentation is valid. Change this when we know
## what must be valid R code, similar to the above for undoc().
@out = grep(!/^(\>|Using)/, @out);
if($#out>=0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
## </FIXME>
}
## Check whether all arguments shown in \usage are documented in
## \arguments.
if(-d "man") {
$log->checking("for undocumented arguments in \\usage");
my $Rcmd = "$TMPDIR/Rcmd.$$";
my $Rout = "$TMPDIR/Rout.$$";
open RCMD, "> $Rcmd" or die "Error: cannot write to \`$Rcmd'\n";
print RCMD "library(tools)\n";
if($opt_install && ($OS eq "unix")) {
print RCMD "checkDocArgs(package = \"${pkgname}\")\n";
}
else {
print RCMD "checkDocArgs(dir = \"${pkgdir}\")\n";
}
close RCMD;
Rsystem("${R_exe} ${R_opts} --quiet < ${Rcmd} > ${Rout}");
my @out;
open ROUT, "< $Rout";
while(<ROUT>) {chomp; push(@out, $_);}
close ROUT;
unlink($Rcmd);
unlink($Rout);
@out = grep(!/^\>/, @out);
if($#out>=0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
}
## Check C sources/headers for CRLF line endings.
if(-d "src") {
$log->checking("for CRLF line endings in C sources/headers");
my @srcfiles = glob("src/*.[ch]");
my @badfiles = ();
foreach my $file (@srcfiles) {
open(SRCFILE, "< $file")
or die "Error: cannot open \`$file' for reading\n";
binmode(SRCFILE); # for Windows
while(<SRCFILE>) {
chop;
if($_ =~ /\r$/) {
push(@badfiles, $file);
last;
}
}
close(SRCFILE);
}
if($#badfiles >= 0) {
$log->warning(" Found the following C sources/headers with " .
"CRLF line endings:");
$log->message(" " . join("\n ", @badfiles));
}
else {
$log->result("OK");
}
}
chdir($pkgoutdir);
## Run the examples.
if($opt_examples && -d "${library}/${pkgname}/R-ex") {
$log->creating("${pkgname}-Ex.R");
my $iszipped = 0;
my $cmd;
if(-e "${library}/${pkgname}/R-ex/Rex.zip") {
$iszipped = 1;
my $UNZIP = &R_getenv("R_UNZIPCMD", "unzip -q");
system("$UNZIP ${library}/${pkgname}/R-ex/Rex.zip " .
"-d ${library}/${pkgname}/R-ex");
}
if($WINDOWS) {
## avoid Rcmd as line may be too long after expansion.
$cmd = "perl ${R_HOME}/bin/massage-Examples ".
"${pkgname} ${library}/${pkgname}/R-ex/*.R ".
"> ${pkgname}-Ex.R";
} else {
$cmd = "${R_CMD} perl ${R_HOME}/share/perl/massage-Examples.pl ".
"${pkgname} ${library}/${pkgname}/R-ex ".
"> ${pkgname}-Ex.R";
}
if(Rsystem($cmd)) {
$log->error();
exit(1);
}
if($iszipped) {
unlink(<${library}/${pkgname}/R-ex/*.R>);
}
$log->result("OK");
$log->checking("examples");
if($opt_use_gct) {
$cmd = "(echo 'gctorture(TRUE)'; cat ${pkgname}-Ex.R) " .
"| ${R_exe} ${R_opts} > ${pkgname}-Ex.Rout";
}
else {
$cmd = "${R_exe} ${R_opts} " .
"< ${pkgname}-Ex.R > ${pkgname}-Ex.Rout";
}
if(Rsystem($cmd)) {
$log->error("running examples failed");
exit(1);
}
$log->result("OK");
}
## Run the package-specific tests.
if($opt_tests && (-d "$pkgdir/tests")) {
$log->checking("tests");
my $testsrcdir = "$pkgdir/tests";
my $testdir = "$pkgoutdir/tests";
if(! -d $testdir) {
if(! mkdir($testdir, 0755)) {
die("Error: cannot create directory $testdir\n");
exit(1);
}
}
chdir($testdir);
while(<$testsrcdir/*>) {
copy($_, basename($_));
}
my $makefiles = "-f ${R_HOME}/share/make/tests.mk";
if($WINDOWS) {$makefiles = "-f ${R_HOME}/share/make/wintests.mk";}
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";
print MAKEVARS "USE_GCT = $opt_use_gct\n";
close MAKEVARS;
$makevars = " -f Makevars";
}
print "\n";
if(system("$MAKE $makefiles $makevars")) {
$log->error();
exit(1);
}
chdir($pkgoutdir);
$log->result("OK");
}
## Run LaTeX on the manual.
if($opt_latex) {
if(-d "$library/$pkgname/latex") {
$ENV{'TEXINPUTS'} =
env_path("$R_HOME/share/texmf", $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(Rsystem("$LATEX ${pkgname}-manual")) {
$log->error();
exit(1);
}
$log->result("OK");
}
}
else {
if($HAVE_LATEX) {
$log->checking("DVI version of manual");
my $Rd2dvi_opts = "--no-preview -o ${pkgname}-manual.dvi";
## <FIXME>
## Surely there is a better way?
$Rd2dvi_opts .= ">/dev/null 2>&1" if($OS eq "unix");
## </FIXME>
if(Rsystem("${R_CMD} Rd2dvi ${Rd2dvi_opts} $pkgdir")) {
$log->error("installation failed");
exit(1);
}
$log->result("OK");
}
}
}
}
#**********************************************************
sub Rsystem
{
my $cmd = $_[0];
if($WINDOWS) {
open(cfile, "> $cfile")
or die "Error: cannot write to \`$cfile'\n";
print cfile "$cmd\n";
close cfile;
$res = system("sh $cfile");
unlink($cfile);
return $res;
} else {
return system($cmd);
}
}
#**********************************************************
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-perms do not check sufficient/correct file permissions
--no-codoc do not check for code/documentation mismatches
--no-examples do not run the examples in the Rd files
--no-install skip installation and associated tests
--no-tests do not run code in tests subdirectory
--no-latex do not run LaTeX on help files
--use-gct use \`gctorture(TRUE)' when running examples/tests
By default, all test sections are turned on.
Email bug reports to <r-bugs\@r-project.org>.
END
exit 0;
}