#! @PERL@
#-*- perl -*-
# Copyright (C) 2000-2002 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::Find;
use File::Path;
use Getopt::Long;
use R::Dcf;
use R::Logfile;
use R::Rdtools;
use R::Utils;
use R::Vars;
use Text::DelimMatch;
use Text::Wrap;
## don't buffer output
$| = 1;
my $revision = ' $Revision: 1.133 $ ';
my $version;
my $name;
$revision =~ / ([\d\.]*) /;
$version = $1;
($name = $0) =~ s|.*/||;
## 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 $opt_vignettes = 1;
my $WINDOWS = ($R::Vars::OSTYPE eq "windows");
R::Vars::error("R_HOME", "R_CMD", "R_EXE");
my @known_options = ("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", "no-vignettes");
GetOptions(@known_options) or 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;
$opt_vignettes = 0 if $opt_no_vignettes;
my $startdir = cwd();
$opt_outdir = $startdir unless $opt_outdir;
chdir($opt_outdir)
or die "Error: cannot change to directory '$opt_outdir'\n";
my $outdir = cwd();
chdir($startdir);
my $R_LIBS = $ENV{'R_LIBS'};
my $library;
if($opt_library) {
chdir($opt_library)
or 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,
"> " . &file_path(${R::Vars::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($R::Vars::TMPDIR);
if(R_system("${R::Vars::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,
"< " . &file_path(${R::Vars::R_HOME}, "doc", "KEYWORDS.db"))
or die "Error: cannot open 'KEYWORDS.db'";
while(<KEYWORDS>) {
if(/^.*\|([^:]*):.*/) {
$standard_keywords{$1} = 1;
}
}
close(KEYWORDS);
## <FIXME>
## We now always redefine T/F when running the examples, but warn about
## an empty R_CHECK_WITH_T_N_F_AS_NULL environment variable intended to
## disable the redefinition.
## Remove this eventually, and also the test in massage-Examples.pl.
if(defined($ENV{'R_CHECK_WITH_T_N_F_AS_NULL'})
&& $ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} eq "") {
my $log = new R::Logfile();
$log->message("redefining R_CHECK_WITH_T_N_F_AS_NULL to 'yes'");
$log->close();
}
$ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} = "yes";
## 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) or die "Error: package dir '$pkg' does not exist";
chdir($pkg)
or die "Error: cannot change to directory '$pkg'\n";
my $pkgdir = cwd();
my $pkgname = basename($pkgdir);
chdir($startdir);
my $pkgoutdir = &file_path($outdir, "$pkgname.Rcheck");
rmtree($pkgoutdir) if ($opt_clean && (-d $pkgoutdir)) ;
if(!(-d $pkgoutdir)) {
mkdir($pkgoutdir, 0755)
or die("Error: cannot create directory '$pkgoutdir'\n");
}
$log = new R::Logfile(&file_path($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 &file_path($pkgdir, "DESCRIPTION.in")) {
$description =
new R::Dcf(&file_path($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) {
$log->checking(join("",
("for file '",
&file_path($pkgname, "DESCRIPTION"),
"'")));
if(-r &file_path($pkgdir, "DESCRIPTION")) {
$description =
new R::Dcf(&file_path($pkgdir, "DESCRIPTION"));
$log->result("OK");
}
else {
$log->result("NO");
exit(1);
}
## <NOTE>
## This check should be adequate, but would not catch a manually
## installed package, nor one installed prior to 1.4.0.
## </NOTE>
$log->checking("if this is a source package");
if(!defined($description->{"Built"})) {
$log->result("OK")
} else {
$log->error();
$log->print("Only *source* packages can be checked.\n");
exit(1);
}
if($opt_install) {
print("\n");
my $cmd = "${R::Vars::R_CMD} INSTALL -l $library $pkgdir";
if(R_system($cmd)) {
$log->error();
$log->print("Installation failed.\n");
exit(1);
}
print("\n");
}
}
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(&file_path($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)
or die "Error: cannot change to directory '$pkg'\n";
$pkgdir = cwd();
$pkgname = basename($pkgdir);
}
else {
$log->error();
$log->print("Package directory '$pkg' does not exist.\n");
exit(1);
}
$log->result("OK");
chdir($pkgdir);
## Check for sufficient file permissions (Unix only).
## This is a bit controversial, and hence there is a command line
## 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 NAMESPACE
## data/* demo/* exec/* 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 && ($R::Vars::OSTYPE eq "unix")) {
$log->checking("for sufficient/correct file permissions");
my @bad_files = ();
my @excludepatterns = R::Utils::get_exclude_patterns();
## <FIXME>
## This is not right for bundles where the build ignore pattern
## file is in the top-level bundle dir. We could fix this by
## using '../.Rbuildignore' instead, but then
## find(\&find_wrong_perms_A, ".");
## find(\&find_wrong_perms_B, ".");
## are wrong because the exclude patterns are relative to '..'.
if(-f "./.Rbuildignore") {
open(RBUILDIGNORE, "./.Rbuildignore");
while(<RBUILDIGNORE>) {
chop;
push(@exclude_patterns, $_) if $_;
}
close(RBUILDIGNORE);
}
## </FIXME>
## Phase A. Directories at least 755, files at least 644.
sub find_wrong_perms_A {
my $filename = $File::Find::name;
$filename =~ s/^[^\/]*\///;
foreach my $p (@exclude_patterns) {
if($WINDOWS) {
## Argh: Windows is case-honoring but not
## case-insensitive ...
return 0 if($filename =~ /$p/i);
}
else {
return 0 if($filename =~ /$p/);
}
}
if(-d $_ && (((stat $_)[2] & 00755) < oct("755"))) {
push(@bad_files, $File::Find::name);
}
if(-f $_ && (((stat $_)[2] & 00644) < oct("644"))) {
push(@bad_files, $File::Find::name);
}
}
find(\&find_wrong_perms_A, ".");
if($#bad_files >= 0) {
$log->error();
$log->print("Found the following files with " .
"insufficient permissions:\n");
$log->print(" " . join("\n ", @bad_files) . "\n");
$log->print(wrap("", "",
("Permissions should be at least 755",
"for directories and 644 for files.\n")));
$log->print("Please fix permissions and try again.\n");
exit(1);
}
## Phase B. Text files (as determined by their extensions)
## should really be mode 644.
@bad_files = ();
my @textfile_patterns =
("\\.[RSdqr]\$", # R source code
"\\.[Rr]d\$", # Rd files
"\\.([Ccfh]|cc|cpp)\$",
# C/C++/FORTRAN sources and headers
"^(DESCRIPTION|COPYING|INDEX|NAMESPACE|README)\$");
sub find_wrong_perms_B {
my $filename = $File::Find::name;
$filename =~ s/^[^\/]*\///;
foreach my $p (@exclude_patterns) {
return 0 if($filename =~ /$p/);
}
if(-f $_ && (((stat $_)[2] & 00777) != oct("644"))) {
foreach my $p (@textfile_patterns) {
if($filename =~ /$p/) {
push(@bad_files, $File::Find::name);
last;
}
}
}
}
find(\&find_wrong_perms_B, ".");
if($#bad_files >= 0) {
$log->warning();
$log->print("Found the following text files with " .
"incorrect permissions:\n");
$log->print(" " . join("\n ", @bad_files) . "\n");
$log->print(wrap("", "",
("Permissions for text files",
"(including R, Rd, and C/C++/FORTRAN",
"sources) should be exactly 644.\n")));
$log->print("Please fix permissions.\n");
}
else {
$log->result("OK");
}
}
## Check DESCRIPTION meta-information.
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);
}
}
my @msg_DESCRIPTION
= ("See the information on DESCRIPTION files",
"in section 'Creating R packages'",
"of the 'Writing R Extensions' manual.\n");
$log->checking("DESCRIPTION meta-information");
## Mandatory entries in DESCRIPTION:
## Package, Version, License, Description, Title, Author,
## Maintainer.
foreach my $field (qw(Package Version License Description Title
Author Maintainer)) {
if(!$description->{$field}) {
$log->error();
$log->print("No DESCRIPTION $field field found.\n");
$log->print(wrap("", "", @msg_DESCRIPTION));
exit(1);
}
}
if($description->{"Package"} !~ /^[a-z][a-z\d\.]*$/i) {
$log->error();
$log->print("Malformed package name.\n");
$log->print(wrap("", "", @msg_DESCRIPTION));
exit(1);
}
if($description->{"Package"} ne $pkgname) {
$log->error();
$log->print("DESCRIPTION Package field differs from dir name.\n");
$log->print(wrap("", "", @msg_DESCRIPTION));
exit(1);
}
if(($description->{"Version"} !~ /^\d+([.-]\d+)+$/)
&& !$is_base_pkg) {
## Package sources from the R distribution have '@VERSION@' in
## their 'DESCRIPTION.in' files ...
$log->error();
$log->print("Malformed package version.\n");
$log->print(wrap("", "", @msg_DESCRIPTION));
exit(1);
}
if($description->{"Maintainer"} !~ /^[^<>]*<[^<>]+> *$/) {
$log->error();
$log->print("Malformed Maintainer field.\n");
$log->print(wrap("", "", @msg_DESCRIPTION));
exit(1);
}
## Optional entries in DESCRIPTION:
## Depends.
## These must be correct if present.
if($description->{"Depends"}) {
my @dependencies = split(/\,\s*/, $description->{"Depends"});
my @matches;
my ($is_bad_dep_op, $is_bad_dep_version);
my ($bad_dep_value, @bad_dep_error);
foreach my $dep (@dependencies) {
@matches =
($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
## '-'.
$is_bad_dep_op =
(($matches[2] ne "<=") && ($matches[2] ne ">="));
$is_bad_dep_version = ($matches[3] =~ /[^\d\.\-]/);
if(!($matches[0])
|| ($matches[1]
&& ($is_bad_dep_op || $is_bad_dep_version))) {
$bad_dep_entry = $dep;
if(!($matches[0])) {
@bad_dep_error =
("Entries must be names of packages, optionally",
"followed by '<=' or '>=', white space, and a",
"valid version number in parentheses.\n");
}
elsif($is_bad_dep_op) {
@bad_dep_error =
("Infeasible comparison operator '$matches[2]'.\n",
"Only operators '<=' and '>=' are possible.\n");
}
elsif($is_bad_dep_version) {
@bad_dep_error =
("Infeasible version number '$matches[3]'.\n",
"Version numbers must only contain digits,",
"'.' or '-'.\n");
}
break;
}
}
if($bad_dep_entry) {
$log->error();
$log->print("Malformed Depends field.\n");
$log->print("Offending entry is: '$bad_dep_entry'.\n");
$log->print(wrap("", "", @bad_dep_error));
$log->print(wrap("", "", @msg_DESCRIPTION));
exit(1);
}
}
$log->result("OK");
## Try figuring out whether the package dependencies can be resolved
## at run time. Ideally, the installation mechanism would do this,
## and we also do not check versions ...
##
## Need to do this here because we need the 'real' DESCRIPTION file
## (also in the case of bundles), and to know that its 'Depends'
## field is syntactically correct.
if($description->{"Depends"} && $opt_install) {
$log->checking("package dependencies");
my @required_packages = ();
my @dependencies = split(/\,/, $description->{"Depends"});
foreach my $dep (@dependencies) {
$dep =~ s/^\s*([\w\.]+).*$/\1/;
next if($dep eq "R");
push(@required_packages, $dep);
}
if($#required_packages >= 0) {
my $Rcmd = "requiredPackages <- c(\"";
$Rcmd .= join("\", \"", @required_packages);
$Rcmd .= "\")\n";
$Rcmd .= "writeLines(requiredPackages[!requiredPackages %in% ";
$Rcmd .= "installed.packages()[ , \"Package\"]])\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet");
@out = grep(!/^\>/, @out);
if($#out >= 0) {
$log->error();
$log->print("Packages required but not available:\n");
$log->print(wrap(" ", " ", @out) . "\n");
exit(1);
}
}
$log->result("OK");
}
## Check index information.
$log->checking("index information");
my @msg_index = ("See the information on INDEX files and package",
"subdirectories in section 'Creating R packages'",
"of the 'Writing R Extensions' manual.\n");
my $any = 0;
if(-z "INDEX") {
## If there is an empty INDEX file, we get no information about
## the package contents ...
$any++;
$log->warning();
$log->print("Empty file 'INDEX'.\n");
}
if((-d "demo")
&& &list_files_with_type("demo", "demo")) {
my $index = &file_path("demo", "00Index");
if(!(-s $index)) {
$log->warning() unless($any);
$any++;
$log->print("Empty or missing file '$index'.\n");
}
else {
my $dir = "demo";
my $cmd = "library(tools)\n";
$cmd .= ".checkDemoIndex(\"$dir\")\n";
my @out = R_runR($cmd, "${R_opts} --quiet");
@out = grep(!/^\>/, @out);
if($#out >= 0) {
$log->warning() unless($any);
$any++;
$log->print(join("\n", @out) . "\n");
}
}
}
if((-d &file_path("inst", "doc"))
&& &list_files_with_type(&file_path("inst", "doc"),
"vignette")) {
my $dir = &file_path("inst", "doc");
my $cmd = "library(tools)\n";
$cmd .= ".checkVignetteIndex(\"$dir\")\n";
my @out = R_runR($cmd, "${R_opts} --quiet");
@out = grep(!/^\>/, @out);
if($#out >= 0) {
$log->warning() unless($any);
$any++;
$log->print(join("\n", @out) . "\n");
}
}
if($any) {
$log->print(wrap("", "", @msg_index));
}
else {
$log->result("OK");
}
## Check package subdirectories.
if((-d "data") || (-d "demo") || (-d "src") || (-d "inst")) {
$log->checking("package subdirectories");
my $any;
## Subdirectory 'data' without data sets?
if((-d "data") && !&list_files_with_type("data", "data")) {
$log->warning() unless $any;
$any++;
$log->print("Subdirectory 'data' contains no data sets.\n");
}
## Subdirectory 'demo' without demos?
if((-d "demo") && !&list_files_with_type("demo", "demo")) {
$log->warning() unless $any;
$any++;
$log->print("Subdirectory 'demo' contains no demos.\n");
}
## Subdirectory 'src' without sources?
## <NOTE>
## If there is a Makefile (or a Makefile.win), we cannot assume
## that source files have the predefined extensions.
## </NOTE>
if((-d "src")
&& !(&list_files_with_exts("src", "([Ccf]|cc|cpp)")
|| (-f &file_path("src", "Makefile"))
|| (-f &file_path("src", "Makefile.win")))) {
$log->warning() unless $any;
$any++;
$log->print("Subdirectory 'src' contains no source files.\n");
}
## Do subdirectories of 'inst' interfere with R package system
## subdirectories?
if((-d "inst")) {
my @R_system_subdirs = ("Meta", "R", "data", "demo", "exec",
"man", "help", "html", "latex", "R-ex");
my @bad_dirs = ();
foreach my $dir (@R_system_subdirs) {
push(@bad_dirs, $dir)
if((-d &file_path("inst", $dir))
&& &list_files(file_path("inst", $dir)));
}
if($#bad_dirs >= 0) {
$log->warning() unless $any;
$any++;
$log->print(wrap("", "",
("Found the following non-empty",
"subdirectories of 'inst' also",
"used by R:\n")));
$log->print(" " . join(" ", @bad_dirs) . "\n");
$log->print(wrap("", "",
("It is recommended not to interfere",
"with package subdirectories",
"used by R.\n")));
}
}
$log->result("OK") unless $any;
}
## Check R code for syntax errors.
if(!$is_base_pkg && (-d "R")) {
$log->checking("R files for syntax errors");
## <NOTE>
## We could/should really check *all* OS specific subdirs here.
my @R_files = &list_files_with_type("R", "code");
## </NOTE>
my $Rcmd = "RFiles <- c(\"";
$Rcmd .= join("\",\n\"", @R_files) . "\")\n";
$Rcmd .= "for(f in RFiles)\n";
$Rcmd .= "if(inherits(try(parse(f)), \"try-error\")) stop(f)\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet");
@out = grep(/^Error:/, @out);
if($#out >= 0) {
my $Rfile = $out[0];
$Rfile =~ s/^Error: *//;
$log->error();
$log->print("Syntax error in file " . $Rfile . "\n");
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 @R_files;
if($opt_install) {
## Only need to check the installed file (if installed).
@R_files = (&file_path($library, $pkgname, "R", $pkgname));
}
else {
## Otherwise (if the package was not installed), we need to
## check all R code files.
## <NOTE>
## We could/should really check all OS specific subdirs here.
@R_files = &list_files_with_type("R", "code");
## </NOTE>
}
my $any = 0;
my $ext;
foreach my $file (@R_files) {
last if $any;
open(FILE, "< $file")
or die "Error: cannot open file '$file' for reading";
while(<FILE>) {
if(/library.dynam\(\"(.*?)\"/o) {
my $arg = $1;
if($arg =~ /\.(so|sl|dll)$/) {
$ext = $1;
$any++;
last;
}
}
}
close(FILE);
}
if($any == 0) {
$log->result("OK");
}
else {
$log->error();
$log->print("library.dynam() used with extension '.$ext'.\n");
$log->print(wrap("", "",
("The system-specific extension for",
"shared libraries should not be added.\n")));
$log->print("See ?library.dynam\n");
exit(1);
}
}
## Check whether methods have all arguments of the corresponding
## generic.
if(-d "R") {
$log->checking("generic/method consistency");
my $Rcmd = "library(tools)\n";
if($opt_install) {
$Rcmd .= "checkMethods(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "checkMethods(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet");
@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 = "library(tools)\n";
if($opt_install) {
$Rcmd .= "checkAssignFuns(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "checkAssignFuns(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet");
@out = grep(!/^\>/, @out);
if($#out >= 0) {
## <NOTE>
## We really want to stop if we find offending assignment
## functions. But we cannot use error() because output may
## contain warnings ...
$log->warning();
## </NOTE>
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
}
## Check foreign function calls.
if((-d "R") && $ENV{'R_CHECK_FF_CALLS'}) {
$log->checking("foreign function calls");
my $Rcmd = "library(tools)\n";
if($opt_install) {
$Rcmd .= "checkFF(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "checkFF(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet");
@out = grep(!/^\>/, @out);
if($#out >= 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
}
## Check R documentation files.
if(-d "man") {
$log->checking("Rd files");
my @Rd_files =
&list_files_with_type("man", "docs", $R::Vars::OSTYPE);
## Rd files with illegal file names?
my @bad_files = grep(/</, @Rd_files);
if($#bad_files >= 0) {
$log->error();
$log->print("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:\n");
$log->print(" " . join("\n ", @bad_files) . "\n");
exit(1);
}
@Rd_files = sort(@Rd_files);
## <FIXME>
## The code below tries to deal with common problems in Rd
## files, such as unbalanced braces, missing mandatory tags or
## duplicated tags which must be unique, etc. This is tricky:
## in particular, one needs to deal with Rd preprocessing (which
## could e.g. eliminate mandatory tags or duplicated tags which
## must be unique). So at least in theory, for Rd files which
## use preprocessor conditionals, one would need to repeat the
## tests for at least all supported OS types. Argh ...
## </FIXME>
my @mandatory_tags = qw(name alias title description keyword);
my @unique_tags = qw(name title description usage arguments
format details value references source
seealso examples note author synopsis);
my @bad_braces;
my @bad_names;
my @bad_titles;
my %bad_keywords;
my %bad_mandatory_tags;
my %bad_unique_tags;
## Create hash all_tags with all tags found in mandatory_tags
## and unique_tags.
my %all_tags;
foreach my $tag (@mandatory_tags, @unique_tags) {
$all_tags{$tag}++;
}
foreach my $file (@Rd_files) {
## Call the Rd preprocessor first.
my $text = &Rdpp($file, $R::Vars::OSTYPE);
## And split into lines again.
my @lines = split(/\n/, $text);
## Check tags and keywords.
my %keywords;
my %tagcount;
foreach my $line (@lines) {
foreach my $tag (keys %all_tags) {
if($line =~ /^\s*\\$tag\{/) {
$tagcount{$tag}++;
}
}
if($line =~ /^\s*\\keyword\{\s*([^}]*[^}\s])\s*\}.*/) {
$keywords{$1} = 1;
}
}
foreach my $tag (@mandatory_tags) {
push(@{$bad_mandatory_tags{$tag}}, $file)
unless ($tagcount{$tag} > 0);
}
foreach my $tag (@unique_tags) {
push(@{$bad_unique_tags{$tag}}, $file)
unless ($tagcount{$tag} <= 1);
}
foreach my $key (keys(%keywords)) {
push(@{$bad_keywords{$file}}, $key)
unless $standard_keywords{$key};
}
## Check name and title.
## Note that the code here is based on Rd::info().
## (Not entirely safe ...)
$text =~ /\\name\{\s*([^\}]+)\s*\}/s;
push(@bad_names, $file) if($1 =~ /^\s*$/);
$text =~ /\\title\{\s*([^\}]+)\s*\}/s;
push(@bad_titles, $file) if($1 =~ /^\s*$/);
## Check for unbalanced braces.
$text = "";
## Get rid of the \alias entries as these may have
## unbalanced braces (Paren.Rd).
foreach my $line (@lines) {
$text .= "\n$line" unless ($line =~ /^\s*\\alias/);
}
$text .= "\n";
my $delimcurly = new Text::DelimMatch;
$delimcurly->delim("\{", "\}");
$delimcurly->escape("\\");
$text =~ s/([^\\])%.*\n/$1\n/g; # ???
## Now loop through matching pairs of braces.
while($delimcurly->match($text)) {
$text = $delimcurly->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(@bad_braces, $file);
}
}
my $any = 0;
my @msg_writing_Rd
= ("See chapter 'Writing R documentation'",
"in manual 'Writing R Extensions'.\n");
if($#bad_braces >= 0) {
$log->error();
$log->print("Rd files with unbalanced braces:\n");
$log->print(" " . join("\n ", @bad_braces) . "\n");
$log->print(wrap("", "",
("Unbalanced braces are Rd syntax",
"errors, and result in incorrect",
"documentation.\n")));
exit(1);
}
if($#bad_names >= 0) {
$log->error();
$log->print("Rd files with missing or empty '\\name':\n");
$log->print(" " . join("\n ", @bad_names) . "\n");
$log->print(wrap("", "", @msg_writing_Rd));
exit(1);
}
if($#bad_titles >= 0) {
$log->error();
$log->print("Rd files with missing or empty '\\title':\n");
$log->print(" " . join("\n ", @bad_titles) . "\n");
$log->print(wrap("", "", @msg_writing_Rd));
exit(1);
}
my $any_missing_mandatory_tag = 0;
foreach my $tag (@mandatory_tags) {
if(exists $bad_mandatory_tags{$tag}) {
$log->warning() unless $any;
$any++;
$any_missing_mandatory_tag++;
$log->print("Rd files without '${tag}':\n");
$log->print(" " .
join("\n ", @{$bad_mandatory_tags{$tag}}) .
"\n");
}
}
if($any_missing_mandatory_tag) {
$log->print("These tags are required in an Rd file.\n");
$log->print(wrap("", "", @msg_writing_Rd));
}
my $any_duplicate_unique_tag = 0;
foreach my $tag (@unique_tags) {
if(exists $bad_unique_tags{$tag}) {
$log->warning() unless $any;
$any++;
$any_duplicate_unique_tag++;
$log->print("Rd files with duplicate '${tag}':\n");
$log->print(" " .
join("\n ", @{$bad_unique_tags{$tag}}) .
"\n");
}
}
if($any_duplicate_unique_tag) {
$log->print("These tags must be unique in an Rd file.\n");
$log->print(wrap("", "", @msg_writing_Rd));
}
if(keys(%bad_keywords)) {
$log->warning() unless $any;
$any++;
$log->print("Rd files with non-standard keywords:\n");
foreach my $file (keys(%bad_keywords)) {
$log->print(wrap(" ", " ",
("'$file':",
@{$bad_keywords{$file}},
"\n")));
}
$log->print(wrap("", "",
("Each '\\keyword' entry should specify",
"one of the standard keywords",
"(as listed in file 'KEYWORDS.db'",
"in the 'doc' subdirectory",
"of the R home directory).\n")));
$log->print(wrap("", "", @msg_writing_Rd));
}
$log->result("OK") unless $any;
}
## Check for undocumented objects.
if(((-d "R") || (-d "data")) && (-d "man")) {
$log->checking("for undocumented objects");
my $Rcmd = "library(tools)\n";
if($opt_install) {
$Rcmd .= "undoc(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "undoc(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet");
my @err = grep(/^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();
$log->print(join("\n", @err) . "\n");
exit(1);
}
}
## Check for code/documentation mismatches.
if($opt_codoc && (-d "R") && (-d "man")) {
$log->checking("for code/documentation mismatches");
my $Rcmd = "library(tools)\n";
if($opt_install) {
$Rcmd .= "codoc(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "codoc(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet");
## <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(!/^\>/, @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 = "library(tools)\n";
if($opt_install) {
$Rcmd .= "checkDocArgs(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "checkDocArgs(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet");
@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.
## <FIXME>
## Does ISO C really require LF line endings? (Reference?)
## We definitely know that Solaris cc will not accept CRLF or CR
## line endings.
## Note that we currently only check the CRLF part.
## </FIXME>
if(!$is_base_pkg && (-d "src")) {
$log->checking("for CRLF line endings in C sources/headers");
my @src_files = &list_files_with_exts("src", "[ch]");
my @bad_files = ();
foreach my $file (@src_files) {
open(FILE, "< $file")
or die "Error: cannot open '$file' for reading\n";
binmode(FILE); # for Windows
while(<FILE>) {
chop;
if($_ =~ /\r$/) {
push(@bad_files, $file);
last;
}
}
close(FILE);
}
if($#bad_files >= 0) {
$log->warning();
$log->print("Found the following C sources/headers with " .
"CRLF line endings:\n");
$log->print(" " . join("\n ", @bad_files) . "\n");
$log->print("ISO C requires LF line endings.\n");
}
else {
$log->result("OK");
}
}
chdir($pkgoutdir);
## Run the examples.
if($opt_examples && (-d &file_path($library, $pkgname, "R-ex"))) {
$log->creating("${pkgname}-Ex.R");
my $Rexdir = &file_path($library, $pkgname, "R-ex");
my $iszipped = 0;
my $cmd;
if(-e &file_path($Rexdir, "Rex.zip")) {
$iszipped = 1;
my $UNZIP = &R_getenv("R_UNZIPCMD", "unzip -q");
$cmd = join(" ",
("$UNZIP",
&file_path($Rexdir, "Rex.zip"),
" -d $Rexdir"));
if(R_system($cmd)) {
$log->error();
$log->print("Cannot extract examples from ZIP archive.\n");
exit(1);
}
}
if($WINDOWS) {
## avoid Rcmd as line may be too long after expansion.
$cmd = "perl ${R::Vars::R_HOME}/bin/massage-Examples ".
"${pkgname} ${library}/${pkgname}/R-ex ".
"> ${pkgname}-Ex.R";
} else {
$cmd = join(" ",
("${R::Vars::R_CMD} perl",
&file_path(${R::Vars::R_HOME}, "share", "perl",
"massage-Examples.pl"),
"${pkgname} ${Rexdir} > ${pkgname}-Ex.R"));
}
if(R_system($cmd)) {
$log->error();
$log->print("Running massage-Examples to create " .
"${pkgname}-Ex.R failed.\n");
exit(1);
}
if($iszipped) {
unlink(&list_files_with_exts($Rexdir, "R"));
}
$log->result("OK");
$log->checking("examples");
if($opt_use_gct) {
$cmd = "(echo 'gctorture(TRUE)'; cat ${pkgname}-Ex.R) " .
"| ${R::Vars::R_EXE} ${R_opts} > ${pkgname}-Ex.Rout 2>&1";
}
else {
$cmd = "${R::Vars::R_EXE} ${R_opts} " .
"< ${pkgname}-Ex.R > ${pkgname}-Ex.Rout 2>&1";
}
if(R_system($cmd)) {
$log->error();
$log->print("Running examples failed.\n");
exit(1);
}
$log->result("OK");
}
## Run the package-specific tests.
if($opt_install && $opt_tests && (-d &file_path($pkgdir, "tests"))) {
$log->checking("tests");
my $testsrcdir = &file_path($pkgdir, "tests");
my $testdir = &file_path($pkgoutdir, "tests");
if(!(-d $testdir)) {
mkdir($testdir, 0755)
or die "Error: cannot create directory '$testdir'\n";
}
chdir($testdir);
foreach my $file (&list_files($testsrcdir)) {
copy($file, basename($file));
}
my $makefiles = "-f " . &file_path(${R::Vars::R_HOME},
"share", "make",
"tests.mk");
if($WINDOWS) {
$makefiles = "-f ${R::Vars::R_HOME}/share/make/wintests.mk";}
my $makevars = "";
if($WINDOWS && (-r "$testsrcdir/Makefile.win")) {
$makefiles .= " -f $testsrcdir/Makefile.win";
}
elsif(-r &file_path($testsrcdir, "Makefile")) {
$makefiles .= " -f " . &file_path($testsrcdir, "Makefile");
}
if($WINDOWS && (-r "$testsrcdir/Makevars.win")) {
$makevars = " -f $testsrcdir/Makevars.win";
}
elsif(-r &file_path($testsrcdir, "Makevars")) {
$makevars = " -f " . &file_path($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 =";
foreach my $file (&list_files_with_exts($testdir, "R")) {
print MAKEVARS "\\\n " . basename($file);
}
print MAKEVARS "\n";
print MAKEVARS "test-src-auto =";
foreach my $file (&list_files_with_exts($testdir, "Rin")) {
$file =~ s/Rin$/R/;
print MAKEVARS "\\\n " . basename($file);
}
print MAKEVARS "\n";
print MAKEVARS "USE_GCT = $opt_use_gct\n";
close(MAKEVARS);
$makevars = " -f Makevars";
}
print "\n";
if(R_system("${R::Vars::MAKE} $makefiles $makevars")) {
$log->error();
exit(1);
}
chdir($pkgoutdir);
$log->result("OK");
}
chdir($pkgoutdir);
if((-d &file_path($pkgdir, "inst", "doc"))
&& &list_files_with_type(&file_path($pkgdir, "inst", "doc"),
"vignette")) {
$log->checking(join("",
("package vignettes in '",
&file_path("inst", "doc"),
"'")));
my $any = 0;
## Do PDFs exist for all package vignettes?
my @vignette_files =
&list_files_with_type(&file_path($pkgdir, "inst", "doc"),
"vignette");
my @bad_vignettes = ();
foreach my $file (@vignette_files) {
my $pdf_file = $file;
$pdf_file =~ s/\.[[:alpha:]]+$/.pdf/;
push(@bad_vignettes, $file) unless(-f $pdf_file);
}
if($#bad_vignettes >= 0) {
$log->warning();
$any++;
$log->print("Package vignettes without corresponding PDF:\n");
$log->print(" " . join("\n ", @bad_vignettes) . "\n");
}
## Can we run the code in the vignettes?
if($opt_vignettes) {
my $Rcmd = "library(tools)\n";
if($opt_install) {
$Rcmd .= "checkVignettes(package=\"${pkgname}\", " .
"lib.loc = \"$pkgoutdir\", " .
"workdir=\"src\")\n";
}
else {
$Rcmd .= "checkVignettes(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet");
@out = grep(!/^\>/, @out);
if($#out >= 0) {
$log->warning() unless($any);
$any++;
$log->print(join("\n", @out) . "\n");
}
}
$log->result("OK") unless($any);
}
## Run LaTeX on the manual.
if($opt_latex) {
if(-d &file_path($library, $pkgname, "latex")) {
$ENV{'TEXINPUTS'} =
env_path(&file_path($R::Vars::R_HOME, "share", "texmf"),
$ENV{'TEXINPUTS'});
$log->creating("${pkgname}-manual.tex");
open(MANUAL, "> ${pkgname}-manual.tex")
or die("Error: cannot open file '${pkgname}-manual.tex'" .
"for writing");
print MANUAL "\\documentclass\{article\}\n" .
"\\usepackage[ae,hyper]\{Rd\}\n\\begin\{document\}\n";
my @tex_files =
&list_files_with_exts(&file_path($library, $pkgname,
"latex"),
"tex");
foreach my $file (@tex_files) {
open(FILE, "< $file")
or die("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");
## <NOTE>
## We use \nonstopmode{} so that LaTeX really gives an
## error (and returns) if something is wrong, and all
## info goes to ${pkgname}-manual.log.
## We also suppress all output from running LaTeX.
## We could also write stdout to a tempfile and replay
## this in case of problems. But does this really help?
my $cmd = "${R::Vars::LATEX}";
$cmd .= " '\\nonstopmode{}\\input{${pkgname}-manual.tex}'";
$cmd .= " >/dev/null";
$cmd .= " 2>&1" if($R::Vars::OSTYPE eq "unix");
## </NOTE>
if(R_system($cmd)) {
$log->error();
$log->print("Could not create DVI version.\n");
$log->print("This typically indicates Rd problems.\n");
exit(1);
}
$log->result("OK");
}
}
else {
if($HAVE_LATEX) {
$log->checking("DVI version of manual");
my $cmd = "${R::Vars::R_CMD} Rd2dvi --batch " .
"--no-preview -o ${pkgname}-manual.dvi >/dev/null 2>&1";
$cmd .= " 2>&1" if($R::Vars::OSTYPE eq "unix");
$cmd .= " $pkgdir";
if(R_system($cmd)) {
$log->error();
$log->print("Could not create DVI version.\n");
$log->print("This typically indicates Rd problems.\n");
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
successfully.
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-vignettes do not check vignettes in Sweave format
--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;
}