#! @PERL@
#-*- perl -*-
## Copyright (C) 2000-2006 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., 51 Franklin Street,
## Fifth Floor, Boston, MA 02110-1301 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 IO::File;
use R::Dcf;
use R::Logfile;
use R::Rdtools;
use R::Utils;
use R::Vars;
use Text::Wrap;
## Don't buffer output.
$| = 1;
my $revision = ' $Rev$ ';
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_install = 1;
my $opt_vignettes = 1;
my $opt_use_valgrind = 0;
my $opt_rcfile = ""; # Only set this if $ENV{"HOME"} is set.
$opt_rcfile = &file_path($ENV{"HOME"}, ".R", "check.conf")
if defined($ENV{"HOME"});
my $opt_subdirs;
my $WINDOWS = ($R::Vars::OSTYPE eq "windows");
R::Vars::error("R_HOME", "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",
"install=s" => \$opt_install, "no-install",
"no-vignettes", "use-valgrind" => \$opt_use_valgrind,
"rcfile=s" => \$opt_rcfile,
"check-subdirs=s" => \$opt_subdirs);
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_install = 0 if $opt_no_install;
$opt_vignettes = 0 if $opt_no_vignettes;
if($opt_install eq "fake") {
## If we fake installation, then we cannot *run* any code.
$opt_examples = $opt_tests = $opt_vignettes = 0;
}
$opt_install = 0 if($opt_install eq "no");
my $opt_ff_calls = 1;
## The neverending story ...
## For the time being, allow to turn this off by setting the environment
## variable _R_CHECK_FF_CALLS_ to a Perl 'null' value.
if(defined($ENV{"_R_CHECK_FF_CALLS_"})) {
$opt_ff_calls = $ENV{"_R_CHECK_FF_CALLS_"};
}
## Use system default unless explicitly specified otherwise.
$ENV{"R_DEFAULT_PACKAGES"} = "";
### Configurable variables
my $R_check_use_install_log =
&R_getenv("_R_CHECK_USE_INSTALL_LOG_", "TRUE");
my $R_check_subdirs_nocase =
&R_getenv("_R_CHECK_SUBDIRS_NOCASE_", "FALSE");
my $R_check_all_non_ISO_C =
&R_getenv("_R_CHECK_ALL_NON_ISO_C_", "FALSE");
my $R_check_weave_vignettes =
&R_getenv("_R_CHECK_WEAVE_VIGNETTES_", "TRUE");
my $R_check_subdirs_strict =
&R_getenv("_R_CHECK_SUBDIRS_STRICT_", "default");
## Maybe move basic configuration (and documentation) to
## &file_path($R::Vars::R_HOME, "etc", "check.conf")
## eventually ...
for my $file ($opt_rcfile) {
if(-r $file) {
open(FILE, "< $file")
or die "Error: cannot open file '$file' for reading\n";
my @lines = <FILE>;
close(FILE);
eval("@lines");
die "Error: failed to eval config file '$file'\n$@\n" if ($@);
## <NOTE>
## We prefer the above to the usual recommendation
## unless ($return = do($file)) {
## warn "couldn't parse $file: $@" if $@;
## warn "couldn't do $file: $!" unless defined $return;
## warn "couldn't run $file" unless $return;
## }
## as do(FILE) cannot see lexicals in the enclosing scope.
## </NOTE>
}
}
$R_check_use_install_log =
&config_val_to_logical($R_check_use_install_log);
$R_check_subdirs_nocase =
&config_val_to_logical($R_check_subdirs_nocase);
$R_check_all_non_ISO_C =
&config_val_to_logical($R_check_all_non_ISO_C);
$R_check_weave_vignettes =
&config_val_to_logical($R_check_weave_vignettes);
$opt_subdirs = $R_check_subdirs_strict if $opt_subdirs eq "";
my $startdir = R_cwd();
$opt_outdir = $startdir unless $opt_outdir;
chdir($opt_outdir)
or die "Error: cannot change to directory '$opt_outdir'\n";
my $outdir = R_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 = R_cwd();
$ENV{'R_LIBS'} = env_path($library, $R_LIBS);
chdir($startdir);
}
my $tar = R_getenv("TAR", "tar");
my $gzip = R_getenv("R_GZIPCMD", "gzip");
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 open file 'Rtextest$$.tex' for writing\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();
}
## This is the main loop over all packages to be checked.
(scalar(@ARGV) > 0) or die "Error: no packages were specified\n";
foreach my $pkg (@ARGV) {
## $pkg should be the path to the package (bundle) root source
## directory, either absolute or relative to $startdir.
## As from 2.1.0 it can also be a tarball
## $pkgdir is the corresponding absolute path.
## $pkgname is the name of the package (bundle).
chdir($startdir);
$pkg =~ s+/$++; # strip any trailing '/'
my $pkgname = basename($pkg);
my $thispkg_subdirs = $opt_subdirs;
## is this a tar archive?
my $istar = 0;
if($pkgname =~ /\.tar\.gz$/ || $pkgname =~ /\.tgz$/) {
$pkgname =~ s/\.tar\.gz$//;
$pkgname =~ s/\.tgz$//;
$pkgname =~ s/_[0-9\.-]*$//;
$istar = 1;
$thispkg_subdirs = "yes-maybe" if $thispkg_subdirs eq "default";
} else {
$thispkg_subdirs = "no" if $thispkg_subdirs eq "default";
}
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");
}
if($istar) {
my $dir = &file_path("$pkgoutdir", "00_pkg_src");
mkdir($dir, 0755)
or die("Error: cannot create directory '$dir'\n");
if($WINDOWS) {
## workaround for paths in Cygwin tar
$pkg =~ s+^([A-Za-z]):+/cygdrive/\1+;
}
## this requires GNU tar: ATT 'tar x' does not support -C.
if(R_system("$gzip -dc '$pkg' | $tar -xf - -C $dir")) {
die "Error: cannot untar $pkg\n";}
$pkg = &file_path($dir, $pkgname);
}
$pkg =~ s/\/$//;
(-d $pkg) or die "Error: package dir '$pkg' does not exist\n";
chdir($pkg)
or die "Error: cannot change to directory '$pkg'\n";
my $pkgdir = R_cwd();
## my $pkgname = basename($pkgdir);
my $thispkg_src_subdir = $thispkg_subdirs;
if($thispkg_src_subdir eq "yes-maybe") {
## now see if there is a 'configure' file
## configure files are only used if executable, but
## -x is always false on Windows.
if($WINDOWS) {
$thispkg_src_subdir = "no" if (-f "configure");
} else {
$thispkg_src_subdir = "no" if (-x "configure");
}
}
chdir($startdir);
$log = new R::Logfile(&file_path($pkgoutdir, "00check.log"));
$log->message("using log directory '$pkgoutdir'");
my @out = R_runR("cat(R.version.string, '\n', sep='')",
"--slave --vanilla");
$log->message("using @out");
if(!$opt_library) {
$library = $pkgoutdir;
$ENV{'R_LIBS'} = env_path($library, $R_LIBS);
}
if($WINDOWS) { ## need to avoid spaces in $library
$library = Win32::GetShortPathName($library) if $library =~ / /;
}
my $description;
my $is_base_pkg = 0;
my $is_bundle = 0;
my $package_or_bundle = "package";
my $package_or_bundle_name;
## 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);
}
if($description->{"Type"}) { # standard packages do not have this
$log->checking("extension type");
$log->result($description->{"Type"});
if($description->{"Type"} ne "Package") {
$log->print("Only Type = Package extensions can be checked.\n");
exit(0);
}
}
if($description->{"Bundle"}) {
$is_bundle = 1;
$log->message("looks like '${pkgname}' is a package bundle");
$package_or_bundle = "bundle";
$package_or_bundle_name = $description->{"Bundle"};
}
else {
$package_or_bundle_name = $description->{"Package"};
}
$log->message("this is $package_or_bundle " .
"'$package_or_bundle_name' " .
"version '$description->{\"Version\"}'");
## Check package dependencies.
## <NOTE>
## We want to check for dependencies early, since missing
## dependencies may make installation fail, and in any case we
## give up if they are missing. But we don't check them if
## we are not going to install and hence not run any code.
## </NOTE>
if($opt_install) {
## 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 ... also see whether vignette
## and namespace package dependencies are recorded in DESCRIPTION.
## <NOTE>
## We are not checking base packages here, so all packages do
## have a description file. Bundles should have dependencies
## only at the top level to be usable by install.packages and
## friends, and `Writing R Extensions' requires this.
## </NOTE>
$log->checking("package dependencies");
## Everything listed in Depends or Suggests or Imports
## should be available for successfully running R CMD check.
## \VignetteDepends{} entries not "required" by the package code
## must be in Suggests. Note also that some of us think that a
## package vignette must require its own package, which OTOH is
## not required in the package DESCRIPTION file.
## Namespace imports must really be in Depends.
my $Rcmd = "tools:::.check_package_depends(\"${pkgdir}\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES=NULL");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->error();
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "", @msg_DESCRIPTION));
exit(1);
} else {
$log->result("OK");
}
}
## <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_or_bundle");
if(defined($description->{"Built"})) {
$log->error();
$log->print("Only *source* packages can be checked.\n");
exit(1);
}
elsif($opt_install !~ /^check/) {
## Check for package/bundle 'src' subdirectories with object
## files (but not if installation was already performed).
my $any;
my $pat = "(a|o|[ls][ao]|sl|obj)"; # Object file extensions.
my @dirs;
if($is_bundle) {
foreach my $ppkg (split(/\s+/,
$description->{"Contains"})) {
push(@dirs, &file_path($ppkg, "src"));
}
}
else {
@dirs = ("src");
}
foreach my $dir (@dirs) {
if((-d &file_path($pkgdir, $dir))
&& &list_files_with_exts(&file_path($pkgdir, $dir),
$pat)) {
$log->warning() unless $any;
$any++;
$dir = &file_path($pkgname, $dir);
$log->print("Subdirectory '$dir' " .
"contains object files.\n");
}
}
if($thispkg_src_subdir ne "no") {
foreach my $dir (@dirs) {
if((-d &file_path($pkgdir, $dir))) {
chdir(&file_path($pkgdir, $dir));
if(!(-f "Makefile") && !(-f "Makefile.win")) {
opendir(DIR, ".") or die "cannot opendir $dir: $!";
@srcfiles = grep {
!(/\.([Ccfh]|cc|cpp|f90|f95)$/
|| /^Makevars/ || /-win\.def$/ )
&& -f "$_" } readdir(DIR);
closedir(DIR);
if(@srcfiles) {
$log->warning() unless $any;
$any++;
$log->print("Subdirectory '$dir' contains:\n");
$log->print(wrap(" ", " ",
join(" ", sort @srcfiles) . "\n"));
$log->print(wrap("", "",
("These are unlikely file names",
"for src files.\n")));
}
}
chdir($startdir);
}
}
}
$log->result("OK") unless $any;
}
else {
$log->result("OK");
}
## Option '--no-install' turns off installation and the tests
## which require the package to be installed. When testing
## recommended packages bundled with R we can skip installation,
## and do so if '--install=skip' was given. If command line
## option '--install' is of the form 'check:FILE', it is assumed
## that installation was already performed with stdout/stderr to
## FILE, the contents of which need to be checked (without
## repeating the installation).
## <NOTE>
## In this case, one also needs to specify *where* the package
## was installed to using command line option '--library'.
## Perhaps we should check for that, although '--install=check'
## is really only meant for repository maintainers.
## </NOTE>
if($opt_install) {
if($opt_install eq "skip") {
$log->message("skipping installation test");
}
else {
my $use_install_log =
(($opt_install =~ /^check/) ||
$R_check_use_install_log ||
!(-t STDIN && -t STDOUT));
my $INSTALL_opts = "";
$INSTALL_opts = "--fake" if($opt_install eq "fake");
my $cmd;
if($WINDOWS) {
$cmd = join(" ",
("Rcmd.exe INSTALL -l",
&shell_quote_file_path($library),
"$INSTALL_opts",
&shell_quote_file_path($pkgdir)));
} else {
$cmd = join(" ",
(&shell_quote_file_path(${R::Vars::R_EXE}),
"CMD INSTALL -l",
&shell_quote_file_path($library),
"$INSTALL_opts",
&shell_quote_file_path($pkgdir)));
}
if(!$use_install_log) {
## Case A: No redirection of stdout/stderr from
## installation.
print("\n");
if(R_system($cmd)) {
$log->error();
$log->print("Installation failed.\n");
exit(1);
}
print("\n");
}
else {
## Case B. All output from installation redirected,
## or already available in the log file.
$log->checking("whether $package_or_bundle " .
"'$package_or_bundle_name' " .
"can be installed");
my $out = &file_path($pkgoutdir, "00install.out");
my $install_error;
my @lines;
if($opt_install =~ /^check/) {
copy(substr($opt_install, 6), $out);
$opt_install = "check";
@lines = &read_lines($out);
## <NOTE>
## We used to have
## $install_error =
## ($lines[$#lines] !~ /^\* DONE/);
## but what if there is output from do_cleanup
## in (Unix) R CMD INSTALL?
$install_error =
(scalar(grep(/^\* DONE/, @lines)) == 0);
}
else {
$cmd .= " >" .
&shell_quote_file_path($out) .
" 2>&1";
$install_error = &R_system($cmd);
if($WINDOWS) {
## MS Html Help Compiler gives lines terminated
## by CRCRLF, so we clean up the log file.
my $line;
## read_lines does chomp.
@lines = &read_lines($out);
open(FILE, "> $out")
or die "Error: cannot open file '$out' for re-writing\n";
foreach $line (@lines) {
$line =~ s/\r$//;
print FILE $line, "\n";
}
close(FILE);
}
}
if($install_error) {
$log->error();
$log->print("Installation failed.\n");
$log->print("See '$out' for details.\n");
exit(1);
}
## There could still be some important warnings that
## we'd like to report. For the time being, start
## with compiler warnings about non ISO C code (Or
## at least, what looks like it.) In theory, we
## should only do this when using GCC ...
@lines = &read_lines($out)
unless($opt_install eq "check");
my $warn_re =
"(" . join("|", ("^WARNING:",
"^Warning:",
": warning: .*ISO C",
"missing link\\(s\\):")) . ")";
@lines = grep(/$warn_re/, @lines);
## Ignore install time readLines() warnings about
## files with incomplete final lines. Most of these
## come from .install_package_indices(), and should be
## safe to ignore ...
$warn_re = "Warning: incomplete final line " .
"found by readLines";
@lines = grep(!/$warn_re/, @lines);
## Package writers cannot really do anything about
## non ISO C code in *system* headers. Also, GCC
## 3.4 or better warns about function pointers
## casts which are "needed" for dlsym(), but it
## seems that all systems which have dlsym() also
## support the cast. Hence, try to ignore these by
## default, but make it possible to get all ISO C
## warnings via an environment variable.
if(!$R_check_all_non_ISO_C) {
@lines = grep(!/^ *\/.*: warning: .*ISO C/,
@lines);
$warn_re = "warning: *ISO C forbids.*" .
"function pointer";
@lines = grep(!/$warn_re/, @lines);
}
## Warnings spotted by gfortran 4.0 or better with
## -Wall. Justified in principle, it seems. Let's
## filter them for the time being, and maybe revert
## this lateron ... but make it possible to suppress
## filtering out by setting the internal environment
## variable _R_CHECK_WALL_FORTRAN_ to something
## "true".
my $R_check_Wall_FORTRAN =
&R_getenv("_R_CHECK_WALL_FORTRAN_", "FALSE");
$R_check_Wall_FORTRAN =
&config_val_to_logical($R_check_Wall_FORTRAN);
if(!$R_check_Wall_FORTRAN) {
my $warn_re =
"(" .
join("|",
("Label .* at \\(1\\) defined but not used",
"Line truncated at \\(1\\)",
"ASSIGN statement at \\(1\\)",
"Assigned GOTO statement at \\(1\\)",
"arithmetic IF statement at \\(1\\)")) .
")";
@lines = grep(!/$warn_re/, @lines);
}
if(scalar(@lines) > 0) {
$log->warning();
$log->print("Found the following " .
"significant warnings:\n");
$log->print(" " . join("\n ", @lines) . "\n");
}
else {
$log->result("OK");
}
}
}
}
}
if($is_bundle) {
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 {
chdir($startdir);
check_pkg($pkgdir, $pkgoutdir, $startdir, $library,
$is_bundle, $description, $log, $is_base_pkg,
$thispkg_subdirs);
}
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, $subdirs) = @_;
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 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 = R_cwd();
if($in_bundle) {
$pkgname = basename($pkgdir);
} else {
$pkgname = $description->{"Package"};
}
}
else {
$log->error();
$log->print("Package directory '$pkg' does not exist.\n");
exit(1);
}
$log->result("OK");
chdir($pkgdir);
## Build list of exclude patterns.
my @exclude_patterns = R::Utils::get_exclude_patterns();
my $exclude_file = ".Rbuildignore";
## This is a bit tricky for bundles where the build ignore pattern
## file is in the top-level bundle dir.
$exclude_file = &file_path(dirname($pkgdir), $exclude_file);
if(-f $exclude_file) {
open(RBUILDIGNORE, "< $exclude_file");
while(<RBUILDIGNORE>) {
chop;
push(@exclude_patterns, $_) if $_;
}
close(RBUILDIGNORE);
}
## Check for portable file names.
## Ensure that the names of the files in the package are valid for
## at least the supported OS types. Under Unix, we definitely
## cannot have '/'; under Windows, the control characters as well as
## " * : < > ? \ |
## (i.e., ASCII characters 1 to 31 and 34, 36, 58, 60, 62, 63, 92,
## and 124) are or can be invalid. (In addition, one cannot have
## one-character file names consisting of just ' ', '.', or '~'.)
## Based on information by Uwe Ligges, Duncan Murdoch, and Brian
## Ripley.
## Furthermore, Uwe Ligges says that Windows still does not allow
## the following DOS device names (by themselves or with possible
## extensions):
##
## Name Function
## ---- --------
## CON Keyboard and display
## PRN System list device, usually a parallel port
## AUX Auxiliary device, usually a serial port
## CLOCK$ System real-time clock
## NUL Bit-bucket device
## COM1 First serial communications port
## COM2 Second serial communications port
## COM3 Third serial communications port
## COM4 Fourth serial communications port
## LPT1 First parallel printer port
## LPT2 Second parallel printer port
## LPT3 Third parallel printer port
## In addition, the names of help files get converted to HTML
## file names and so should be valid in URLs. We check that they are
## ASCII and do not contain %, which is what is known to cause troubles.
$log->checking("for portable file names");
my @bad_files = ();
sub find_wrong_names {
my $file_path = $File::Find::name;
$file_path =~ s/^\.[^\/]*\///;
foreach my $p (@exclude_patterns) {
if($WINDOWS) {
## Argh: Windows is case-honoring but not
## case-insensitive ...
return 0 if($file_path =~ /$p/i);
}
else {
return 0 if($file_path =~ /$p/);
}
}
my $file_name = basename($file_path);
if(grep(/[[:cntrl:]\"\*\/\:\<\>\?\\\|]/, $file_name)) {
push(@bad_files, $file_path);
} elsif(dirname($file_path) =~ /man$/) {
my $ch;
foreach $ch (split //, $file_name) {
## collation is ASCII as uselocale is not in effect.
if ($ch eq "%" || $ch lt " " || $ch gt "~") {
push(@bad_files, $file_path);
last;
}
}
} else {
$file_name =~ tr/A-Z/a-z/;
$file_name =~ s/\..*//;
push(@bad_files, $file_path)
if(grep(/^(con|prn|aux|clock\$|nul|lpt[1-3]|com[1-4])$/,
$file_name));
}
}
if($in_bundle) {
chdir(dirname($pkgdir)); # more portable than '..'?
find(\&find_wrong_names, $pkgname);
chdir($pkgname);
}
else {
find(\&find_wrong_names, ".");
}
if(scalar(@bad_files) > 0) {
$log->error();
$log->print("Found the following file(s) with " .
"non-portable file names:\n");
$log->print(" " . join("\n ", @bad_files) . "\n");
$log->print(wrap("", "",
("These are not valid file names",
"on all R platforms.\n",
"Please rename the files and try again.\n",
"See section 'Package structure'",
"in manual 'Writing R Extensions'.\n")));
exit(1);
}
## next check for name clashes on case-insensitive file systems
## (that is on Windows).
%seen = ();
my @duplicated = ();
sub check_case_names {
my $file_path = lc($File::Find::name);
if($seen{$file_path}) {push(@duplicated, $file_path);}
$seen{$file_path} = 1;
}
if($in_bundle) {
chdir(dirname($pkgdir)); # more portable than '..'?
find(\&check_case_names, $pkgname);
chdir($pkgname);
}
else {
find(\&check_case_names, ".");
}
if(scalar(@duplicated) > 0) {
$log->error();
$log->print("Found the following file(s) with " .
"duplicate lower-cased file names:\n");
$log->print(" " . join("\n ", @duplicated) . "\n");
$log->print(wrap("", "",
("File names must not differ just by case",
"to be usable on all R platforms.\n",
"Please rename the files and try again.\n",
"See section 'Package structure'",
"in manual 'Writing R Extensions'.\n")));
exit(1);
}
$log->result("OK");
## Check for sufficient file permissions (Unix only).
## This used to be much more 'aggressive', requiring that dirs and
## files have mode >= 00755 and 00644, respectively (with an error
## if not), and that files know to be 'text' have mode 00644 (with a
## warning if not). We now only require that dirs and files have
## mode >= 00700 and 00400, respectively, and try to fix
## insufficient permission in the INSTALL code (Unix only).
##
## In addition, we check whether files 'configure' and 'cleanup'
## exists in the top-level directory but are not executable, which
## is most likely not what was intended.
if($R::Vars::OSTYPE eq "unix") {
$log->checking("for sufficient/correct file permissions");
my @bad_files = ();
## Phase A. Directories at least 700, files at least 400.
sub find_wrong_perms_A {
my $filename = $File::Find::name;
$filename =~ s/^\.[^\/]*\///;
foreach my $p (@exclude_patterns) {
## Unix only, so no special casing for Windows.
return 0 if($filename =~ /$p/);
}
if(-d $_ && (((stat $_)[2] & 00700) < oct("700"))) {
push(@bad_files, $filename);
}
if(-f $_ && (((stat $_)[2] & 00400) < oct("400"))) {
push(@bad_files, $filename);
}
}
if($in_bundle) {
chdir(dirname($pkgdir)); # more portable than '..'?
find(\&find_wrong_perms_A, $pkgname);
chdir($pkgname);
}
else {
find(\&find_wrong_perms_A, ".");
}
if(scalar(@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 700",
"for directories and 400 for files.\n",
"Please fix permissions",
"and try again.\n")));
exit(1);
}
## Phase B. Top-level scripts 'configure' and 'cleanup' should
## really be mode at least 500, or they will not be necessarily
## be used (or should we rather change *that*?)
@bad_files = ();
foreach my $filename ("configure", "cleanup") {
## This is a bit silly ...
my $ignore = 0;
foreach my $p (@exclude_patterns) {
if($filename =~ /$p/) {
$ignore = 1;
last;
}
}
if(!$ignore
&& (-f $filename)
&& (((stat $filename)[2] & 00500) < oct("500"))) {
push(@bad_files, $filename);
}
}
if(scalar(@bad_files) > 0) {
$log->warning();
$log->print(wrap("", "",
"The following files should most likely",
"be executable (for the owner):\n"));
$log->print(" " . join("\n ", @bad_files) . "\n");
$log->print(wrap("", "",
"Please fix permissions.\n"));
}
else {
$log->result("OK");
}
}
## Check DESCRIPTION meta-information.
## If we just installed the package (via R CMD INSTALL), we already
## validated most of the package DESCRIPTION metadata. Otherwise,
## let us be defensive about this ...
my $full =
!$opt_install || ($opt_install eq "skip") || $is_base_pkg;
&R::Utils::check_package_description($pkgdir, $pkgname, $log,
$in_bundle, $is_base_pkg,
$full);
$log->checking("top-level files");
opendir(DIR, ".") or die "cannot opendir package: $!";
my @topfiles = grep { /^install.R$/ || /^R_PROFILE.R/
&& -f "$_" } readdir(DIR);
closedir(DIR);
if(@topfiles) {
$log->warning();
$log->print(join(" ", @topfiles) . "\n");
$log->print(wrap("", "",
("These files are deprecated.",
"See manual 'Writing R Extensions'.\n")));
} else {
$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 $Rcmd = "options(warn=1)\ntools:::.check_demo_index(\"$dir\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES=NULL");
@out = grep(!/^\>/, @out);
if(scalar(@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 $Rcmd = "options(warn=1)\ntools:::.check_vignette_index(\"$dir\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES=NULL");
@out = grep(!/^\>/, @out);
if(scalar(@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.
$log->checking("package subdirectories");
my $any;
if($R_check_subdirs_nocase) {
## Argh. We often get submissions where 'R' comes out as 'r',
## or 'man' comes out as 'MAN'. Maybe we should warn about this
## unconditionally ...
if((-d "r")) {
$log->warning() unless $any;
$any++;
$log->print("Found subdirectory 'r'.\n");
$log->print("Most likely, this should be 'R'.\n")
}
if((-d "MAN")) {
$log->warning() unless $any;
$any++;
$log->print("Found subdirectory 'MAN'.\n");
$log->print("Most likely, this should be 'man'.\n")
}
}
sub check_subdirs {
my ($dpath) = @_;
my $Rcmd = "tools:::.check_package_subdirs(\"$dpath\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES=NULL");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning() unless($any);
$any++;
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "",
("Please remove or rename the files.\n",
"See section 'Package subdirectories'",
"in manual 'Writing R Extensions'.\n")));
}
}
&check_subdirs(".") unless ($subdirs eq "no");
## 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") && !( (-f &file_path("src", "Makefile"))
|| (-f &file_path("src", "Makefile.win")) )) {
if( !(&list_files_with_exts("src", "([Ccf]|cc|cpp|f90|f95)"))) {
$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", "libs",
"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(scalar(@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(scalar(@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\n";
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",
"See ?library.dynam\n")));
exit(1);
}
}
## Check whether methods have all arguments of the corresponding
## generic.
if(-d "R") {
$log->checking("S3 generic/method consistency");
my @msg_S3_methods =
("See section 'Generic functions and methods'",
"of the 'Writing R Extensions' manual.\n");
my $Rcmd = "options(warn=1)\n";
$Rcmd .= "options(expressions=1000)\n";
if($opt_install) {
$Rcmd .= "tools::checkS3methods(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "tools::checkS3methods(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "", @msg_S3_methods));
}
else {
$log->result("OK");
}
}
## Check whether replacement functions have their final argument
## named 'value'.
if(-d "R") {
$log->checking("replacement functions");
my @msg_replace_funs =
("In R, the argument of a replacement function",
"which corresponds to the right hand side",
"must be named 'value'.\n");
my $Rcmd = "options(warn=1)\n";
if($opt_install) {
$Rcmd .= "tools::checkReplaceFuns(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "tools::checkReplaceFuns(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
## <NOTE>
## We really want to stop if we find offending replacement
## functions. But we cannot use error() because output may
## contain warnings ...
$log->warning();
## </NOTE>
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "", @msg_replace_funs));
}
else {
$log->result("OK");
}
}
## Check foreign function calls.
if($opt_ff_calls && (-d "R")) {
$log->checking("foreign function calls");
my @msg_ff_calls =
("See section 'System and foreign language interfaces'",
"of the 'Writing R Extensions' manual.\n");
my $Rcmd = "options(warn=1)\n";
if($opt_install) {
$Rcmd .= "tools::checkFF(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "tools::checkFF(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "", @msg_ff_calls));
}
else {
$log->result("OK");
}
}
## Check R code for possible problems using LT's codetools package
## available from http://www.stat.uiowa.edu/~luke/R/codetools, and
## scheduled for integration into base R eventually).
## Activated only via setting the internal environment variable
## _R_CHECK_USE_CODETOOLS_ to something "true".
my $R_check_use_codetools =
&R_getenv("_R_CHECK_USE_CODETOOLS_", "FALSE");
$R_check_use_codetools =
&config_val_to_logical($R_check_use_codetools);
if($R_check_use_codetools && $opt_install && (-d "R")) {
$log->checking("R code for possible problems");
my $Rcmd = "options(warn=1)\n";
$Rcmd .= "tools:::.check_code_usage_in_package(package = \"${pkgname}\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
## <FIXME>
## Temporarily work around R 2.3.0 NULL environment changes.
@out = grep(!/^Warning: use of NULL environment is deprecated/,
@out);
## </FIXME>
if(scalar(@out) > 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
}
## Check R documentation files.
my @msg_writing_Rd
= ("See chapter 'Writing R documentation files'",
"in manual 'Writing R Extensions'.\n");
if(-d "man") {
$log->checking("Rd files");
my $Rcmd = "options(warn=1)\ntools:::check_Rd_files_in_man_dir(\"man\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES=NULL");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
## Output may indicate warnings or errors ...
if(grep(/^Rd files with (syntax errors|missing or empty)/,
@out)) {
$log->error();
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "", @msg_writing_Rd));
exit(1);
}
else {
$log->warning();
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "", @msg_writing_Rd));
}
}
else {
$log->result("OK");
}
}
## Check cross-references in R documentation files.
## <NOTE>
## Installing a package warns about missing links (and hence R CMD
## check knows about this too provided an install log is used).
## However, under Windows the install-time check verifies the links
## against what is available in the default library, which might be
## considerably more than what can be assumed to be available.
##
## The formulations in section "Cross-references" of R-exts are not
## quite clear about this, but CRAN policy has for a long time
## enforced anchoring links to targets (aliases) from non-base
## packages.
##
## For the time being, if the package is installed only run the test
## if the internal environment variable _R_CHECK_RD_XREFS_ is set to
## something "true". Most likely one should always run the check if
## no install log is used.
if(-d "man") {
my $R_check_Rd_xrefs = &R_getenv("_R_CHECK_RD_XREFS_", "FALSE");
$R_check_Rd_xrefs = &config_val_to_logical($R_check_Rd_xrefs);
if(($opt_install && $R_check_Rd_xrefs) || !$opt_install) {
$log->checking("Rd cross-references");
my $Rcmd = "options(warn=1)\n";
if($opt_install) {
$Rcmd .= "tools:::.check_Rd_xrefs(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "tools:::.check_Rd_xrefs(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES=NULL");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
}
}
## Check for missing documentation entries.
if(((-d "R") || (-d "data"))) {
$log->checking("for missing documentation entries");
my $Rcmd= "options(warn=1)\n";
if($opt_install) {
$Rcmd .= "tools::undoc(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "tools::undoc(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
my @err = grep(/^Error/, @out);
@out = grep(!/^\>/, @out);
if(scalar(@err) > 0) {
$log->error();
$log->print(join("\n", @err) . "\n");
exit(1);
}
elsif(scalar(@out) > 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
my $details;
$details = " (including S4 classes and methods)"
if(grep(/^Undocumented S4/, @out));
$log->print(wrap("", "",
("All user-level objects",
"in a package${details} should",
"have documentation entries.\n")));
$log->print(wrap("", "", @msg_writing_Rd));
}
else {
$log->result("OK");
}
}
## Check for code/documentation mismatches.
if($opt_codoc && (-d "man")) {
$log->checking("for code/documentation mismatches");
my $any = 0;
## Check for code/documentation mismatches in functions.
if(-d "R") {
my $Rcmd = "options(warn=1)\n";
if($opt_install) {
$Rcmd .= "tools::codoc(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "tools::codoc(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$any++;
$log->warning();
$log->print(join("\n", @out) . "\n");
}
}
## Check for code/documentation mismatches in data sets.
if($opt_install) {
my $Rcmd = "options(warn=1)\ntools::codocData(package = \"${pkgname}\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning() unless($any);
$any++;
$log->print(join("\n", @out) . "\n");
}
}
## Check for code/documentation mismatches in S4 classes.
if($opt_install && (-d "R")) {
my $Rcmd = "options(warn=1)\ntools::codocClasses(package = \"${pkgname}\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning() unless($any);
$any++;
$log->print(join("\n", @out) . "\n");
}
}
$log->result("OK") unless($any);
}
## Check Rd files, for consistency of \usage with \arguments (are
## all arguments shown in \usage documented in \arguments?) and
## aliases (do all functions shown in \usage have an alias?)
if(-d "man") {
$log->checking("Rd \\usage sections");
my @msg_doc_files =
("Functions with \\usage entries",
"need to have the appropriate \\alias entries,",
"and all their arguments documented.\n",
"The \\usage entries must correspond to syntactically",
"valid R code.\n");
my $Rcmd = "options(warn=1)\n";
if($opt_install) {
$Rcmd .= "tools::checkDocFiles(package = \"${pkgname}\")\n";
}
else {
$Rcmd .= "tools::checkDocFiles(dir = \"${pkgdir}\")\n";
}
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
$log->print(wrap("", "", @msg_doc_files));
$log->print(wrap("", "", @msg_writing_Rd));
}
else {
$log->result("OK");
}
}
## Check C/C++/Fortran sources/headers for CRLF line endings.
## <FIXME>
## Does ISO C really require LF line endings? (Reference?)
## We definitely know that some versions of Solaris cc and f77
## 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/C++/Fortran sources/headers");
my @src_files = &list_files_with_exts("src", "(c|h|f|cc|cpp)");
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(scalar(@bad_files) > 0) {
$log->warning();
$log->print("Found the following sources/headers with " .
"CRLF line endings:\n");
$log->print(" " . join("\n ", @bad_files) . "\n");
$log->print("Some Unix compilers require LF line endings.\n");
}
else {
$log->result("OK");
}
}
## Check src/Makevars[.in] for portable compilation flags.
if((-f &file_path("src", "Makevars.in"))
|| (-f &file_path("src", "Makevars"))) {
$log->checking("for portable compilation flags in Makevars");
my $Rcmd = "tools:::.check_make_vars(\"src\")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet",
"R_DEFAULT_PACKAGES=NULL");
@out = grep(!/^\>/, @out);
if(scalar(@out) > 0) {
$log->warning();
$log->print(join("\n", @out) . "\n");
}
else {
$log->result("OK");
}
}
chdir($pkgoutdir);
## Run the examples.
## This setting applies to vignettes below too.
${R_opts} = ${R_opts}." -d valgrind" if $opt_use_valgrind;
if($opt_examples && (-d &file_path($library, $pkgname, "R-ex"))) {
$log->creating("${pkgname}-Ex.R");
my $Rexdir = &file_path($library, $pkgname, "R-ex");
## $Rexdir might contain spaces (not on Windows)
my $is_zipped = 0;
my $cmd;
if(-e &file_path($Rexdir, "Rex.zip")) {
$is_zipped = 1;
my $UNZIP = &R_getenv("R_UNZIPCMD", "unzip");
my $Rexfile = &file_path($Rexdir, "Rex.zip");
$cmd = join(" ",
("$UNZIP", "-q",
&shell_quote_file_path($Rexfile),
"-d",
&shell_quote_file_path($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.
## We've forced R_HOME and Rexdir to have no spaces already.
$cmd = "perl ${R::Vars::R_HOME}/bin/massage-Examples ".
"${pkgname} ${Rexdir} ".
"> ${pkgname}-Ex.R";
} else {
$cmd =
join(" ",
(&shell_quote_file_path(${R::Vars::R_EXE}),
"CMD perl",
&shell_quote_file_path(&file_path(${R::Vars::R_SHARE_DIR},
"perl",
"massage-Examples.pl")),
"${pkgname}",
&shell_quote_file_path(${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($is_zipped) {
unlink(&list_files_with_exts($Rexdir, "R"));
}
$log->result("OK");
$log->checking("examples");
if($opt_use_gct) {
$cmd = join(" ",
("(echo 'gctorture(TRUE)';",
"cat ${pkgname}-Ex.R) |",
&shell_quote_file_path(${R::Vars::R_EXE}),
"${R_opts}",
"> ${pkgname}-Ex.Rout 2>&1"));
} else {
$cmd = join(" ",
(&shell_quote_file_path(${R::Vars::R_EXE}),
"${R_opts}",
"< ${pkgname}-Ex.R",
"> ${pkgname}-Ex.Rout 2>&1"));
}
if(R_system($cmd)) {
$log->error();
$log->print("Running examples in ${pkgname}-Ex.R failed.\n");
## Try to spot the offending example right away.
my $txt = join("\n", &read_lines("${pkgname}-Ex.Rout"));
## Look for the header section anchored by a subsequent call
## to flush(): needs to be kept in sync with the code in
## massage-Examples.pl. Should perhaps also be more
## defensive about the prompt ...
my @chunks = split(/(> \#\#\# \* [^\n]+\n> \n> flush)/, $txt);
if(scalar(@chunks) > 2) {
$log->print("The error most likely occurred in:\n\n");
$log->print($chunks[$#chunks - 1]);
$log->print($chunks[$#chunks] . "\n");
}
exit(1);
}
## Look at the output from running the examples. For the time
## being, report warnings about use of deprecated functions, as
## the next release will make them defunct and hence using them
## an error. Also warn about loading defunct base package stubs,
## as load special-casing for these will be removed eventually.
my @lines = &read_lines("${pkgname}-Ex.Rout");
my $any;
my @bad_lines;
@bad_lines = grep(/^Warning: .*is deprecated.$/, @lines);
if(scalar(@bad_lines) > 0) {
$log->warning();
$any++;
$log->print("Found the following significant warnings:\n");
$log->print(" " . join("\n ", @bad_lines) . "\n");
$log->print(wrap("", "",
("Deprecated functions may be defunct as",
"soon as of the next release of R.\n",
"See ?Deprecated.\n")));
}
@bad_lines = grep(/^Warning: package '.*' has been merged into/,
@lines);
## Could make this more precise by looking for an exact match
## for one of the defunct stubs, but we currently do not get
## R_PKGS_STUBS from 'share/make/vars.mk'.
if(scalar(@bad_lines) > 0) {
if($any) {
$log->print("\nAdditional significant warnings:\n");
}
else {
$log->warning();
$any++;
$log->print("Found the following significant " .
"warnings:\n");
}
$log->print(" " . join("\n ", @bad_lines) . "\n");
$log->print(wrap("", "",
("Support for loading defunct former base",
"packages may be removed as soon as of",
"the next release of R.\n")));
}
$log->result("OK") unless($any);
}
## 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 " .
&shell_quote_file_path(&file_path(${R::Vars::R_SHARE_DIR},
"make", "tests.mk"));
if($WINDOWS) {
$makefiles = "-f ${R::Vars::R_SHARE_DIR}/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 (sort &list_files_with_exts($testdir, "R")) {
print MAKEVARS "\\\n " . basename($file);
}
print MAKEVARS "\n";
print MAKEVARS "test-src-auto =";
foreach my $file (sort &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";
print MAKEVARS "R_OPTS = -d valgrind\n" if $opt_use_valgrind;
close(MAKEVARS);
$makevars = " -f Makevars";
}
print "\n";
if(R_system("${R::Vars::MAKE} $makefiles $makevars")) {
$log->error();
exit(1);
}
chdir($pkgoutdir);
$log->result("OK");
}
## Check package vignettes.
chdir($pkgoutdir);
my $vignette_dir = &file_path($pkgdir, "inst", "doc");
if((-d $vignette_dir)
&& &list_files_with_type($vignette_dir, "vignette")) {
$log->checking(join(" ",
("package vignettes in",
&sQuote(&file_path("inst", "doc")))));
my $any = 0;
## Do PDFs exist for all package vignettes?
my @vignette_files =
&list_files_with_type($vignette_dir, "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);
}
## A base package may not have PDFs to avoid blowing out the
## distribution size. *Note* that it is assumed that base
## packages can be woven (i.e., that they only contain
## "standard" LaTeX).
if(!$is_base_pkg && scalar(@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_install && $opt_vignettes) {
## Should checking the vignettes assume the system default
## packages, or just base?
my $Rcmd = "options(warn=1)\nlibrary(tools)\n";
## A base package does not get installed during check.
if(!$is_base_pkg && $opt_install) {
$Rcmd .= "checkVignettes(package = \"${pkgname}\", " .
"lib.loc = \"${library}\", " .
"workdir = \"src\"";
}
else {
$Rcmd .= "checkVignettes(dir = \"${pkgdir}\"";
}
$Rcmd .= ", weave = FALSE" if(!$R_check_weave_vignettes);
$Rcmd .= ")\n";
my @out = R_runR($Rcmd, "${R_opts} --quiet");
## Vignette could redefine the prompt, e.g. to 'R>' ...
@out = grep(!/^[[:alnum:]]*\>/, @out);
## Or to "empty". As empty lines in the output will most
## likely not indicate a problem ...
@out = grep(!/^[[:space:]]*$/, @out);
if(scalar(@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) {
my $latex_dir = &file_path($library, $pkgname, "latex");
if(-d $latex_dir) {
$ENV{'TEXINPUTS'} =
env_path(&file_path($R::Vars::R_SHARE_DIR, "texmf"),
$ENV{'TEXINPUTS'});
my $is_zipped = 0;
# latex files might have been zipped
if(-f &file_path($latex_dir, "Rhelp.zip")) {
$is_zipped = 1;
my $UNZIP = &R_getenv("R_UNZIPCMD", "unzip");
my $latex_file = &file_path($latex_dir, "Rhelp.zip");
$cmd = join(" ",
("$UNZIP", "-q",
&shell_quote_file_path($latex_file),
"-d",
&shell_quote_file_path($latex_dir)));
if(R_system($cmd)) {
$log->error();
$log->print("Unzipping latex files failed.\n");
exit(1);
}
}
$log->creating("${pkgname}-manual.tex");
my @tex_files = &list_files_with_exts($latex_dir, "tex");
my %encodings;
foreach my $file (@tex_files) {
open(FILE, "< $file")
or die("Error: cannot open file '$file' for reading\n");
while(<FILE>) {
if (/^\\inputencoding/) {
$enc = $_;
chomp $enc;
$enc =~ s/^\\inputencoding{(.*)}/\1/;
$encodings{$enc} = $enc;
}
}
close(FILE);
}
my $encs = "";
if (scalar(%encodings)) {
$encs = "\\usepackage[" . join(",", values %encodings) .
"]{inputenc}";
}
open(MANUAL, "> ${pkgname}-manual.tex")
or die("Error: cannot open file '${pkgname}-manual.tex'" .
"for writing\n");
print MANUAL "\\documentclass\{article\}\n" . $encs .
"\\usepackage[ae,hyper]\{Rd\}\n\\begin\{document\}\n";
foreach my $file (@tex_files) {
open(FILE, "< $file")
or die("Error: cannot open file '$file' for reading\n");
while(<FILE>) {
print MANUAL $_;
}
close(FILE);
}
print MANUAL "\\end\{document\}\n";
close(MANUAL);
if($is_zipped) {
unlink(&list_files_with_exts($latex_dir, "tex"));
}
$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}";
if($WINDOWS) {
## check if we have MiKTeX and call latex accordingly
## (can't do this in R::Vars::LATEX as we need R::Utils.)
my $Rout = R_tempfile("Rlatex");
my $cmd2 = "$cmd --version > ${Rout}";
R_system($cmd2);
my $is_miktex = 0;
open ROUT, "< $Rout";
while (<ROUT>) {
chomp;
$is_miktex = 1 if /^MiKTeX/;
}
close ROUT;
unlink($Rout);
$out =~ s/\w//;
if($is_miktex) {
my $R_HOME = $ENV{"R_HOME"};
$cmd .= " --include-directory=$R_HOME/share/texmf";
}
}
$cmd .= " '\\nonstopmode{}\\input{${pkgname}-manual.tex}'";
$cmd .= " >/dev/null 2>&1";
## </NOTE>
if(R_system($cmd)) {
$log->error();
$log->print("LaTeX errors when creating DVI version.\n");
$log->print("This typically indicates Rd problems.\n");
## If possible, indicate the problems found.
## GNU grep rather usefully has a '-A' option for
## controlling the number of lines of trailing
## context after matching lines (not POSIX; maybe
## sed could do this?). Not sure how to do this in
## Perl. For the time being, try 'grep -A', and
## give no additional info if this fails.
my $out = R_tempfile("gout");
my $cmd = "grep -A4 '^!' ${pkgname}-manual.log";
$cmd .= " > ${out} 2>/dev/null";
if(!R_system($cmd)) {
$log->print("LaTeX errors found:\n\n");
$log->print(join("\n", &read_lines("${out}")) .
"\n");
}
unlink($out);
exit(1);
}
$log->result("OK");
}
}
else {
if($HAVE_LATEX) {
$log->checking("DVI version of manual");
my $cmd;
if($WINDOWS) {
$cmd = join(" ",
("Rcmd.exe Rd2dvi --batch --no-preview",
"-o ${pkgname}-manual.dvi >/dev/null 2>&1",
"$pkgdir"));
} else {
$cmd = join(" ",
(&shell_quote_file_path("${R::Vars::R_EXE}"),
"CMD Rd2dvi --batch --no-preview",
"-o ${pkgname}-manual.dvi >/dev/null 2>&1",
"$pkgdir"));
}
if(R_system($cmd)) {
$log->error();
$log->print("LaTeX errors when creating 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] pkgs
Check R packages from package sources, which can be directories or
gzipped package 'tar' archives with extension '.tar.gz' or '.tgz'.
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 to see if they
run successfully.
Options:
-h, --help print short help message and exit
-v, --version print 'check' 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-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
--use-valgrind use 'valgrind' when running examples/tests/vignettes
--check-subdirs=default|yes|no
run checks on the package subdirectories
(default is yes for a tarball, no otherwise)
--rcfile=FILE read configuration values from FILE
By default, all test sections are turned on.
Email bug reports to <r-bugs\@r-project.org>.
END
exit 0;
}