The R Project SVN – R – Diff – /trunk/src/scripts/check.in


#! @PERL@
#-*- perl -*-
 
# Copyright (C) 2000-2004 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.168 $ ';
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 $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",
		    "install=s" => \$opt_install, "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_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");
 
## Use system default unless explicitly specified otherwise.
$ENV{"R_DEFAULT_PACKAGES"} = "";
 
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 $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 'doc/KEYWORDS.db'\n";
while(<KEYWORDS>) {
    if(/^.*\|([^:]*):.*/) {
	$standard_keywords{$1} = 1;
    }
}
close(KEYWORDS);
 
## Get the names of base and recommended packages for later.
my @R_pkgs_base = ();
my @R_pkgs_recommended = ();
open(MAKEVARS,
     "< " . &file_path(${R::Vars::R_HOME}, "share", "make", "vars.mk"))
  or die "Error: cannot open 'share/make/vars.mk'\n";
while(<MAKEVARS>) {
    @R_pkgs_base =
	split(/ +/, $2) if(/^(R_PKGS_BASE *=)(.*)/);
    @R_pkgs_recommended =
	split(/ +/, $2) if(/^(R_PKGS_RECOMMENDED *=)(.*)/);
}
 
## <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";
## </FIXME>
 
## This is the main loop over all packages to be checked.
($#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.
    ## $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\n";
    chdir($pkg)
	or die "Error: cannot change to directory '$pkg'\n";
    my $pkgdir = R_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);
	}
	## 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/) ||
		     $ENV{"R_CHECK_USE_INSTALL_LOG"} ||
		     !(-t STDIN && -t STDOUT));
		my $cmd = "${R::Vars::R_CMD} INSTALL -l ${library}";
		$cmd .= " --fake" if($opt_install eq "fake");
		$cmd .= " ${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 '$pkgname' " .
				   "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);
			$install_error =
			    ($lines[$#lines] !~ /^\* DONE/);
		    }
		    else {
			$cmd .= " > $out 2>&1";
			$install_error = &R_system($cmd);
		    }
		    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);
		    if(scalar(@lines) > 0) {
			$log->warning();
			$log->print("Found the following " .
				    "significant warnings:\n");
			$log->print("  " . join("\n  ", @lines) . "\n");
		    }
		    else {
			$log->result("OK");
		    }
		}
	    }
	}
 
    }
 
    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 = R_cwd();
	$pkgname = basename($pkgdir);
    }
    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();
    ## <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 e.g.
    ##   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>
 
    ## 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
 
    $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);
	}
	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));
	}
    }
    find(\&find_wrong_names, ".");
    if($#bad_files >= 0) {
	$log->error();
	$log->print("Found the following files 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);
    }
 
    $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);
	    }
	}
        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 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($#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($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"} !~ /^[^<>]*<[^<>@]+@[^<>@]+> *$/) &&
       ($description->{"Maintainer"} !~ /ORPHANED/)) {
	$log->error();
	$log->print("Malformed Maintainer field.\n");
	$log->print(wrap("", "", @msg_DESCRIPTION));
	exit(1);
    }
 
    ## Optional entries in DESCRIPTION:
    ##   Depends, Namespace, Priority.
    ## 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);
	}
    }
 
    if($description->{"Namespace"}) {
	if($description->{"Namespace"} ne $description->{"Package"}) {
	    $log->error();
	    $log->print("Namespace and Package fields differ.\n");
	    $log->print(wrap("", "", @msg_DESCRIPTION));
	    exit(1);
	}
    }
 
    if($description->{"Priority"}) {
	if($description->{"Priority"} =~ /^(base|recommended)/i) {
	    ## Simplify matters by treating high priority packages
	    ## together.
	    my $found = 0;
	    foreach my $p (@R_pkgs_base, @R_pkgs_recommended) {
		if($description->{"Package"} eq $p) {
		    $found = 1;
		    break;
		}
	    }
	    if(!$found) {
		$log->error();
		$log->print("Invalid Priority field.\n");
		$log->print(wrap("", "",
				 ("Packages with priorities 'base' or",
				  "'recommended' must already be known",
				  "to R.\n")));
		$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"} || $description->{"Suggests"})
       && $opt_install) {
	$log->checking("package dependencies");
	my @required_packages = ();
	my @dependencies =
	  (split(/\,/, $description->{"Depends"}),
	   split(/\,/, $description->{"Suggests"}),
	   $description->{"Package"});
	## According to FL, everything listed in Depends or Suggests
	## 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.
	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");
		$log->print(wrap("", "", @msg_DESCRIPTION));
		exit(1);
	    }
	}
	my $any = 0;
	if((-d &file_path("inst", "doc"))
	   && &list_files_with_type(&file_path("inst", "doc"),
				    "vignette")) {
	    my $dir = &file_path("inst", "doc");
	    my $cmd = "reqs <- ";
	    if(scalar(@required_packages) > 0) {
		$cmd .= "c(\"" .
		  join("\", \"", @required_packages) .
		  "\")\n";
	    }
	    else {
		$cmd .= "character()\n";
	    }
	    $cmd .= "deps <- tools:::.buildVignetteIndex(\"$dir\")\$Depends\n";
	    $cmd .= "deps <- unique(sort(unlist(deps)))\n";
	    $cmd .= "writeLines(deps[!deps %in% reqs])\n";
	    my @out = R_runR($cmd, "${R_opts} --quiet",
			     "R_DEFAULT_PACKAGES=tools");
	    @out = grep(!/^\>/, @out);
	    if($#out >= 0) {
		$any++;
		$log->warning();
		$log->print("Vignette dependencies not required:\n");
		$log->print(wrap("  ", "  ", @out) . "\n");
		$log->print(wrap("", "", @msg_DESCRIPTION));
	    }
	}
 
	$log->result("OK") unless($any);
    }
 
    ## 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 = ".checkDemoIndex(\"$dir\")\n";
	    my @out = R_runR($cmd, "${R_opts} --quiet",
			     "R_DEFAULT_PACKAGES=tools");
	    @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 = ".checkVignetteIndex(\"$dir\")\n";
	my @out = R_runR($cmd, "${R_opts} --quiet",
			 "R_DEFAULT_PACKAGES=tools");
	@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.
 
    $log->checking("package subdirectories");
    my $any;
    if($ENV{"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")
	}
    }
    if((-d "data") || (-d "demo") || (-d "src") || (-d "inst")) {
 
 
	## 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\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 $Rcmd;
	if($opt_install) {
	    $Rcmd .= "checkS3methods(package = \"${pkgname}\")\n";
	}
        else {
	    $Rcmd .= "checkS3methods(dir = \"${pkgdir}\")\n";
	}
 
        my @out = R_runR($Rcmd, "${R_opts} --quiet",
			 "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
	@out = grep(!/^\>/, @out);
	if($#out >= 0) {
	    $log->warning();
	    $log->print(join("\n", @out) . "\n");
	}
	else {
	    $log->result("OK");
	}
    }
 
    ## Check whether replacement functions have their final argument
    ## named 'value'.
 
    if(-d "R") {
	$log->checking("for replacement functions with final arg not " .
		       "named 'value'");
	my $Rcmd;
	if($opt_install) {
	    $Rcmd .= "checkReplaceFuns(package = \"${pkgname}\")\n";
	}
	else {
	    $Rcmd .= "checkReplaceFuns(dir = \"${pkgdir}\")\n";
	}
 
        my @out = R_runR($Rcmd, "${R_opts} --quiet",
			 "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
        @out = grep(!/^\>/, @out);
	if($#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");
	}
	else {
	    $log->result("OK");
	}
    }
 
    ## Check foreign function calls.
 
    if((-d "R") && $ENV{'R_CHECK_FF_CALLS'}) {
	$log->checking("foreign function calls");
 
	my $Rcmd;
	if($opt_install) {
	    $Rcmd .= "checkFF(package = \"${pkgname}\")\n";
	}
        else {
	    $Rcmd .= "checkFF(dir = \"${pkgdir}\")\n";
	}
 
        my @out = R_runR($Rcmd, "${R_opts} --quiet",
			 "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
	@out = grep(!/^\>/, @out);
	if($#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 @Rd_files =
	  &list_files_with_type("man", "docs", $R::Vars::OSTYPE);
 
	@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*$/);
	    ## Using LaTeX special characters (# $ % & ~ _ ^ \ { })
	    ## causes the creation of PDF bookmarks to fail.
	    push(@bad_names, $file)
	      if($1 =~ /(\#|\$|\%|\&|\~|\_|\^|\\|\{|\})/);
	    $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;
 
	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 ".
			"or invalid '\\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 missing documentation entries.
 
    if(((-d "R") || (-d "data")) && (-d "man")) {
	$log->checking("for missing documentation entries");
 
	my $Rcmd;
	if($opt_install) {
	    $Rcmd .= "undoc(package = \"${pkgname}\")\n";
	}
	else {
	    $Rcmd .= "undoc(dir = \"${pkgdir}\")\n";
	}
 
        my @out = R_runR($Rcmd, "${R_opts} --quiet",
                         "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
	my @err = grep(/^Error/, @out);
	@out = grep(!/^\>/, @out);
	if($#err < 0) {
	    if($#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");
	    }
	}
	else {
	    $log->error();
	    $log->print(join("\n", @err) . "\n");
	    exit(1);
	}
    }
 
    ## 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;
	    if($opt_install) {
		$Rcmd .= "codoc(package = \"${pkgname}\")\n";
	    }
	    else {
		$Rcmd .= "codoc(dir = \"${pkgdir}\")\n";
	    }
	    my @out = R_runR($Rcmd, "${R_opts} --quiet",
			     "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
 
	    ## <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) {
		$any++;
		$log->warning();
		$log->print(join("\n", @out) . "\n");
	    }
	    ## </FIXME>
	}
 
	## Check for code/documentation mismatches in data sets.
	if($opt_install) {
	    my $Rcmd = "codocData(package = \"${pkgname}\")\n";
	    my @out = R_runR($Rcmd, "${R_opts} --quiet",
			     "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
	    @out = grep(!/^\>/, @out);
	    if($#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 = "codocClasses(package = \"${pkgname}\")\n";
	    my @out = R_runR($Rcmd, "${R_opts} --quiet",
			     "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
	    @out = grep(!/^\>/, @out);
	    if($#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 $Rcmd;
	if($opt_install) {
	    $Rcmd .= "checkDocFiles(package = \"${pkgname}\")\n";
	}
	else {
	    $Rcmd .= "checkDocFiles(dir = \"${pkgdir}\")\n";
	}
 
        my @out = R_runR($Rcmd, "${R_opts} --quiet",
			 "R_DEFAULT_PACKAGES='utils,graphics,stats,tools'");
	@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 in ${pkgname}-Ex.R failed.\n");
	    ## Try to spot the offending example right away.
	    my $txt = join("\n", &read_lines("${pkgname}-Ex.Rout"));
	    #open(FILE, "< ${pkgname}-Ex.Rout");
	    #my @lines = <FILE>;
	    #close(FILE);
	    #my $txt = join("", @lines);
	    ## 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($#chunks > 1) {
		$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.
	my @lines = &read_lines("${pkgname}-Ex.Rout");
	#open(FILE, "< ${pkgname}-Ex.Rout");
	#my @lines = <FILE>;
	#close(FILE);
	@lines = grep(/^Warning: .*is deprecated.$/, @lines);
	if($#lines >= 0) {
	    $log->warning();
	    $log->print("Found the following significant warnings:\n");
	    $log->print("  " . join("\n  ", @lines) . "\n");
	    $log->print(wrap("", "",
			     ("Deprecated functions may be defunct as",
			      "soon as of the next release of R.\n",
			      "See ?Deprecated.\n")));
	}
	else {
	    $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");
    }
 
    ## Check package vignettes.
 
    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) {
	    ## <FIXME>
	    ## Should checking the vignettes assume the system default
	    ## packages, or just base?
	    my $Rcmd = "library(tools)\n";
	    if($opt_install) {
		$Rcmd .= "checkVignettes(package = \"${pkgname}\", " .
		         "lib.loc = \"${library}\", " .
		         "workdir = \"src\")\n";
	    }
	    else {
		$Rcmd .= "checkVignettes(dir = \"${pkgdir}\")\n";
	    }
	    my @out = R_runR($Rcmd, "${R_opts} --quiet");
	    ## </FIXME>
	    ## Vignette could redefine the prompt, e.g. to 'R>' ...
	    @out = grep(!/^[[:alnum:]]*\>/, @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) {
        my $latex_dir = &file_path($library, $pkgname, "latex");
	if(-d $latex_dir) {
	    $ENV{'TEXINPUTS'} =
	      env_path(&file_path($R::Vars::R_HOME, "share", "texmf"),
		       $ENV{'TEXINPUTS'});
            my $was_zipped = 0;
            # latex files might have been zipped
            if(-f &file_path($library, $pkgname, "latex", "Rhelp.zip")) {
                $was_zipped = 1;
                my $cmd = "cd $latex_dir; unzip -qo Rhelp.zip";
                if(R_system($cmd)) {
		    $log->error();
		    $log->print("Unzipping latex files failed.\n");
		    exit(1);
                }
            }
	    $log->creating("${pkgname}-manual.tex");
	    open(MANUAL, "> ${pkgname}-manual.tex")
	      or die("Error: cannot open file '${pkgname}-manual.tex'" .
		     "for writing\n");
	    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\n");
		while(<FILE>) {
		    print MANUAL $_;
		}
		close(FILE);
	    }
	    print MANUAL "\\end\{document\}\n";
	    close(MANUAL);
            if($was_zipped) {
                if(R_system("rm -f $latex_dir/*.tex")) {
		    $log->error();
		    $log->print("Removing unzipped latex files failed.\n");
		    exit(1);
                }
            }
	    $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 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");
		    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";
		$cmd .= " -o ${pkgname}-manual.dvi >/dev/null 2>&1";
		$cmd .= " $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] 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-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;
}

Rev 28220	Rev 28240
1	`#! @PERL@`	1	`#! @PERL@`
2	`#-- perl --`	2	`#-- perl --`
3		3
4	`# Copyright (C) 2000-2004 R Development Core Team`	4	`# Copyright (C) 2000-2004 R Development Core Team`
5	`#`	5	`#`
6	`# This program is free software; you can redistribute it and/or modify`	6	`# This program is free software; you can redistribute it and/or modify`
7	`# it under the terms of the GNU General Public License as published by`	7	`# it under the terms of the GNU General Public License as published by`
8	`# the Free Software Foundation; either version 2, or (at your option)`	8	`# the Free Software Foundation; either version 2, or (at your option)`
9	`# any later version.`	9	`# any later version.`
10	`#`	10	`#`
11	`# This program is distributed in the hope that it will be useful, but`	11	`# This program is distributed in the hope that it will be useful, but`
12	`# WITHOUT ANY WARRANTY; without even the implied warranty of`	12	`# WITHOUT ANY WARRANTY; without even the implied warranty of`
13	`# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU`	13	`# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU`
14	`# General Public License for more details.`	14	`# General Public License for more details.`
15	`#`	15	`#`
16	`# A copy of the GNU General Public License is available via WWW at`	16	`# A copy of the GNU General Public License is available via WWW at`
17	`# http://www.gnu.org/copyleft/gpl.html. You can also obtain it by`	17	`# http://www.gnu.org/copyleft/gpl.html. You can also obtain it by`
18	`# writing to the Free Software Foundation, Inc., 59 Temple Place,`	18	`# writing to the Free Software Foundation, Inc., 59 Temple Place,`
19	`# Suite 330, Boston, MA 02111-1307 USA.`	19	`# Suite 330, Boston, MA 02111-1307 USA.`
20		20
21	`# Send any bug reports to r-bugs@r-project.org`	21	`# Send any bug reports to r-bugs@r-project.org`
22		22
23	`use Cwd;`	23	`use Cwd;`
24	`use File::Basename;`	24	`use File::Basename;`
25	`use File::Copy;`	25	`use File::Copy;`
26	`use File::Find;`	26	`use File::Find;`
27	`use File::Path;`	27	`use File::Path;`
28	`use Getopt::Long;`	28	`use Getopt::Long;`
29	`use R::Dcf;`	29	`use R::Dcf;`
30	`use R::Logfile;`	30	`use R::Logfile;`
31	`use R::Rdtools;`	31	`use R::Rdtools;`
32	`use R::Utils;`	32	`use R::Utils;`
33	`use R::Vars;`	33	`use R::Vars;`
34	`use Text::DelimMatch;`	34	`use Text::DelimMatch;`
35	`use Text::Wrap;`	35	`use Text::Wrap;`
36		36
37	`## don't buffer output`	37	`## don't buffer output`
38	`$\| = 1;`	38	`$\| = 1;`
39		39
40	`my $revision = ' $Revision: 1.167 $ ';`	40	`my $revision = ' $Revision: 1.168 $ ';`
41	`my $version;`	41	`my $version;`
42	`my $name;`	42	`my $name;`
43	`$revision =~ / ([\d\.]*) /;`	43	`$revision =~ / ([\d\.]*) /;`
44	`$version = $1;`	44	`$version = $1;`
45	`($name = $0) =~ s\|.*/\|\|;`	45	`($name = $0) =~ s\|.*/\|\|;`
46		46
47	`## Options`	47	`## Options`
48	`my $opt_clean = 1;`	48	`my $opt_clean = 1;`
49	`my $opt_examples = 1;`	49	`my $opt_examples = 1;`
50	`my $opt_tests = 1;`	50	`my $opt_tests = 1;`
51	`my $opt_latex = 1;`	51	`my $opt_latex = 1;`
52	`my $opt_use_gct = 0;`	52	`my $opt_use_gct = 0;`
53	`my $opt_codoc = 1;`	53	`my $opt_codoc = 1;`
54	`my $opt_install = 1;`	54	`my $opt_install = 1;`
55	`my $opt_vignettes = 1;`	55	`my $opt_vignettes = 1;`
56		56
57	`my $WINDOWS = ($R::Vars::OSTYPE eq "windows");`	57	`my $WINDOWS = ($R::Vars::OSTYPE eq "windows");`
58		58
59	`R::Vars::error("R_HOME", "R_CMD", "R_EXE");`	59	`R::Vars::error("R_HOME", "R_CMD", "R_EXE");`
60		60
61	`my @known_options = ("help\|h", "version\|v", "outdir\|o:s", "library\|l:s",`	61	`my @known_options = ("help\|h", "version\|v", "outdir\|o:s", "library\|l:s",`
62	`"no-clean", "no-examples", "no-tests", "no-latex",`	62	`"no-clean", "no-examples", "no-tests", "no-latex",`
63	`"use-gct" => \$opt_use_gct, "no-codoc",`	63	`"use-gct" => \$opt_use_gct, "no-codoc",`
64	`"install=s" => \$opt_install, "no-install",`	64	`"install=s" => \$opt_install, "no-install",`
65	`"no-vignettes");`	65	`"no-vignettes");`
66	`GetOptions(@known_options) or usage();`	66	`GetOptions(@known_options) or usage();`
67		67
68	`R_version("R add-on package checker", $version) if $opt_version;`	68	`R_version("R add-on package checker", $version) if $opt_version;`
69	`usage() if $opt_help;`	69	`usage() if $opt_help;`
70		70
71	`$opt_clean = 0 if $opt_no_clean;`	71	`$opt_clean = 0 if $opt_no_clean;`
72	`$opt_examples = 0 if $opt_no_examples;`	72	`$opt_examples = 0 if $opt_no_examples;`
73	`$opt_tests = 0 if $opt_no_tests;`	73	`$opt_tests = 0 if $opt_no_tests;`
74	`$opt_latex = 0 if $opt_no_latex;`	74	`$opt_latex = 0 if $opt_no_latex;`
75	`$opt_codoc = 0 if $opt_no_codoc;`	75	`$opt_codoc = 0 if $opt_no_codoc;`
76	`$opt_install = 0 if $opt_no_install;`	76	`$opt_install = 0 if $opt_no_install;`
77	`$opt_vignettes = 0 if $opt_no_vignettes;`	77	`$opt_vignettes = 0 if $opt_no_vignettes;`
78		78
79	`if($opt_install eq "fake") {`	79	`if($opt_install eq "fake") {`
80	`## If we fake installation, then we cannot run any code.`	80	`## If we fake installation, then we cannot run any code.`
81	`$opt_examples = $opt_tests = $opt_vignettes = 0;`	81	`$opt_examples = $opt_tests = $opt_vignettes = 0;`
82	`}`	82	`}`
83	`$opt_install = 0 if($opt_install eq "no");`	83	`$opt_install = 0 if($opt_install eq "no");`
84		84
85	`## Use system default unless explicitly specified otherwise.`	85	`## Use system default unless explicitly specified otherwise.`
86	`$ENV{"R_DEFAULT_PACKAGES"} = "";`	86	`$ENV{"R_DEFAULT_PACKAGES"} = "";`
87		87
88	`my $startdir = R_cwd();`	88	`my $startdir = R_cwd();`
89	`$opt_outdir = $startdir unless $opt_outdir;`	89	`$opt_outdir = $startdir unless $opt_outdir;`
90	`chdir($opt_outdir)`	90	`chdir($opt_outdir)`
91	`or die "Error: cannot change to directory '$opt_outdir'\n";`	91	`or die "Error: cannot change to directory '$opt_outdir'\n";`
92	`my $outdir = R_cwd();`	92	`my $outdir = R_cwd();`
93	`chdir($startdir);`	93	`chdir($startdir);`
94		94
95	`my $R_LIBS = $ENV{'R_LIBS'};`	95	`my $R_LIBS = $ENV{'R_LIBS'};`
96	`my $library;`	96	`my $library;`
97	`if($opt_library) {`	97	`if($opt_library) {`
98	`chdir($opt_library)`	98	`chdir($opt_library)`
99	`or die "Error: cannot change to directory '$opt_library'\n";`	99	`or die "Error: cannot change to directory '$opt_library'\n";`
100	`$library = R_cwd();`	100	`$library = R_cwd();`
101	`$ENV{'R_LIBS'} = env_path($library, $R_LIBS);`	101	`$ENV{'R_LIBS'} = env_path($library, $R_LIBS);`
102		102
103	`chdir($startdir);`	103	`chdir($startdir);`
104	`}`	104	`}`
105		105
106	`my $R_opts = "--vanilla";`	106	`my $R_opts = "--vanilla";`
107		107
108	`if($opt_latex) {`	108	`if($opt_latex) {`
109	`my $log = new R::Logfile();`	109	`my $log = new R::Logfile();`
110	`$log->checking("for working latex");`	110	`$log->checking("for working latex");`
111	`open(TEXFILE,`	111	`open(TEXFILE,`
112	`"> " . &file_path(${R::Vars::TMPDIR}, "Rtextest$$.tex"))`	112	`"> " . &file_path(${R::Vars::TMPDIR}, "Rtextest$$.tex"))`
113	`or die "Error: cannot write to Rtextest$$.tex\n";`	113	`or die "Error: cannot write to Rtextest$$.tex\n";`
114	`print TEXFILE "\\documentclass\{article\}\\begin\{document\}" .`	114	`print TEXFILE "\\documentclass\{article\}\\begin\{document\}" .`
115	`"test\\end\{document\}\n";`	115	`"test\\end\{document\}\n";`
116	`close(TEXFILE);`	116	`close(TEXFILE);`
117	`chdir($R::Vars::TMPDIR);`	117	`chdir($R::Vars::TMPDIR);`
118	`if(R_system("${R::Vars::LATEX} Rtextest$$ > Rtextest$$.out")) {`	118	`if(R_system("${R::Vars::LATEX} Rtextest$$ > Rtextest$$.out")) {`
119	`$log->result("NO");`	119	`$log->result("NO");`
120	`$HAVE_LATEX = 0;`	120	`$HAVE_LATEX = 0;`
121	`} else {`	121	`} else {`
122	`$log->result("OK");`	122	`$log->result("OK");`
123	`$HAVE_LATEX = 1;`	123	`$HAVE_LATEX = 1;`
124	`}`	124	`}`
125	`unlink(<Rtextest$$.*>);`	125	`unlink(<Rtextest$$.*>);`
126	`chdir($startdir);`	126	`chdir($startdir);`
127	`$log->close();`	127	`$log->close();`
128	`}`	128	`}`
129		129
130	`## Get the valid keywords for later.`	130	`## Get the valid keywords for later.`
131	`my %standard_keywords = ();`	131	`my %standard_keywords = ();`
132	`open(KEYWORDS,`	132	`open(KEYWORDS,`
133	`"< " . &file_path(${R::Vars::R_HOME}, "doc", "KEYWORDS.db"))`	133	`"< " . &file_path(${R::Vars::R_HOME}, "doc", "KEYWORDS.db"))`
134	`or die "Error: cannot open 'doc/KEYWORDS.db'\n";`	134	`or die "Error: cannot open 'doc/KEYWORDS.db'\n";`
135	`while(<KEYWORDS>) {`	135	`while(<KEYWORDS>) {`
136	`if(/^.\\|([^:]):.*/) {`	136	`if(/^.\\|([^:]):.*/) {`
137	`$standard_keywords{$1} = 1;`	137	`$standard_keywords{$1} = 1;`
138	`}`	138	`}`
139	`}`	139	`}`
140	`close(KEYWORDS);`	140	`close(KEYWORDS);`
141		141
142	`## Get the names of base and recommended packages for later.`	142	`## Get the names of base and recommended packages for later.`
143	`my @R_pkgs_base = ();`	143	`my @R_pkgs_base = ();`
144	`my @R_pkgs_recommended = ();`	144	`my @R_pkgs_recommended = ();`
145	`open(MAKEVARS,`	145	`open(MAKEVARS,`
146	`"< " . &file_path(${R::Vars::R_HOME}, "share", "make", "vars.mk"))`	146	`"< " . &file_path(${R::Vars::R_HOME}, "share", "make", "vars.mk"))`
147	`or die "Error: cannot open 'share/make/vars.mk'\n";`	147	`or die "Error: cannot open 'share/make/vars.mk'\n";`
148	`while(<MAKEVARS>) {`	148	`while(<MAKEVARS>) {`
149	`@R_pkgs_base =`	149	`@R_pkgs_base =`
150	`split(/ +/, $2) if(/^(R_PKGS_BASE =)(.)/);`	150	`split(/ +/, $2) if(/^(R_PKGS_BASE =)(.)/);`
151	`@R_pkgs_recommended =`	151	`@R_pkgs_recommended =`
152	`split(/ +/, $2) if(/^(R_PKGS_RECOMMENDED =)(.)/);`	152	`split(/ +/, $2) if(/^(R_PKGS_RECOMMENDED =)(.)/);`
153	`}`	153	`}`
154		154
155	`## <FIXME>`	155	`## <FIXME>`
156	`## We now always redefine T/F when running the examples, but warn about`	156	`## We now always redefine T/F when running the examples, but warn about`
157	`## an empty R_CHECK_WITH_T_N_F_AS_NULL environment variable intended to`	157	`## an empty R_CHECK_WITH_T_N_F_AS_NULL environment variable intended to`
158	`## disable the redefinition.`	158	`## disable the redefinition.`
159	`## Remove this eventually, and also the test in massage-Examples.pl.`	159	`## Remove this eventually, and also the test in massage-Examples.pl.`
160	`if(defined($ENV{'R_CHECK_WITH_T_N_F_AS_NULL'})`	160	`if(defined($ENV{'R_CHECK_WITH_T_N_F_AS_NULL'})`
161	`&& $ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} eq "") {`	161	`&& $ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} eq "") {`
162	`my $log = new R::Logfile();`	162	`my $log = new R::Logfile();`
163	`$log->message("redefining R_CHECK_WITH_T_N_F_AS_NULL to 'yes'");`	163	`$log->message("redefining R_CHECK_WITH_T_N_F_AS_NULL to 'yes'");`
164	`$log->close();`	164	`$log->close();`
165	`}`	165	`}`
166	`$ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} = "yes";`	166	`$ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} = "yes";`
167	`## </FIXME>`	167	`## </FIXME>`
168		168
169	`## This is the main loop over all packages to be checked.`	169	`## This is the main loop over all packages to be checked.`
170	`($#ARGV >= 0) or die "Error: no packages were specified\n";`	170	`($#ARGV >= 0) or die "Error: no packages were specified\n";`
171	`foreach my $pkg (@ARGV) {`	171	`foreach my $pkg (@ARGV) {`
172	`## $pkg should be the path to the package (bundle) root source`	172	`## $pkg should be the path to the package (bundle) root source`
173	`## directory, either absolute or relative to $startdir.`	173	`## directory, either absolute or relative to $startdir.`
174	`## $pkgdir is the corresponding absolute path.`	174	`## $pkgdir is the corresponding absolute path.`
175	`## $pkgname is the name of the package (bundle).`	175	`## $pkgname is the name of the package (bundle).`
176	`chdir($startdir);`	176	`chdir($startdir);`
177	`$pkg =~ s/\/$//;`	177	`$pkg =~ s/\/$//;`
178	`(-d $pkg) or die "Error: package dir '$pkg' does not exist\n";`	178	`(-d $pkg) or die "Error: package dir '$pkg' does not exist\n";`
179	`chdir($pkg)`	179	`chdir($pkg)`
180	`or die "Error: cannot change to directory '$pkg'\n";`	180	`or die "Error: cannot change to directory '$pkg'\n";`
181	`my $pkgdir = R_cwd();`	181	`my $pkgdir = R_cwd();`
182	`my $pkgname = basename($pkgdir);`	182	`my $pkgname = basename($pkgdir);`
183	`chdir($startdir);`	183	`chdir($startdir);`
184		184
185	`my $pkgoutdir = &file_path($outdir, "$pkgname.Rcheck");`	185	`my $pkgoutdir = &file_path($outdir, "$pkgname.Rcheck");`
186	`rmtree($pkgoutdir) if ($opt_clean && (-d $pkgoutdir)) ;`	186	`rmtree($pkgoutdir) if ($opt_clean && (-d $pkgoutdir)) ;`
187	`if(!(-d $pkgoutdir)) {`	187	`if(!(-d $pkgoutdir)) {`
188	`mkdir($pkgoutdir, 0755)`	188	`mkdir($pkgoutdir, 0755)`
189	`or die("Error: cannot create directory '$pkgoutdir'\n");`	189	`or die("Error: cannot create directory '$pkgoutdir'\n");`
190	`}`	190	`}`
191		191
192	`$log = new R::Logfile(&file_path($pkgoutdir, "00check.log"));`	192	`$log = new R::Logfile(&file_path($pkgoutdir, "00check.log"));`
193	`$log->message("using log directory '$pkgoutdir'");`	193	`$log->message("using log directory '$pkgoutdir'");`
194		194
195	`if(!$opt_library) {`	195	`if(!$opt_library) {`
196	`$library = $pkgoutdir;`	196	`$library = $pkgoutdir;`
197	`$ENV{'R_LIBS'} = env_path($library, $R_LIBS);`	197	`$ENV{'R_LIBS'} = env_path($library, $R_LIBS);`
198	`}`	198	`}`
199		199
200	`my $description;`	200	`my $description;`
201	`my $is_base_pkg = 0;`	201	`my $is_base_pkg = 0;`
202	`## Package sources from the R distribution are special. They have a`	202	`## Package sources from the R distribution are special. They have a`
203	`## 'DESCRIPTION.in' file (instead of 'DESCRIPTION'), with Version`	203	`## 'DESCRIPTION.in' file (instead of 'DESCRIPTION'), with Version`
204	`## field containing '@VERSION@' for substitution by configure. We`	204	`## field containing '@VERSION@' for substitution by configure. We`
205	`## test for such packages by looking for 'DESCRIPTION.in' with`	205	`## test for such packages by looking for 'DESCRIPTION.in' with`
206	`## Priority 'base', and skip the installation test for such`	206	`## Priority 'base', and skip the installation test for such`
207	`## packages.`	207	`## packages.`
208	`if(-r &file_path($pkgdir, "DESCRIPTION.in")) {`	208	`if(-r &file_path($pkgdir, "DESCRIPTION.in")) {`
209	`$description =`	209	`$description =`
210	`new R::Dcf(&file_path($pkgdir, "DESCRIPTION.in"));`	210	`new R::Dcf(&file_path($pkgdir, "DESCRIPTION.in"));`
211	`if($description->{"Priority"} eq "base") {`	211	`if($description->{"Priority"} eq "base") {`
212	`$log->message("looks like '${pkgname}' is a base package");`	212	`$log->message("looks like '${pkgname}' is a base package");`
213	`$log->message("skipping installation test");`	213	`$log->message("skipping installation test");`
214	`$is_base_pkg = 1;`	214	`$is_base_pkg = 1;`
215	`}`	215	`}`
216	`}`	216	`}`
217		217
218	`if(!$is_base_pkg) {`	218	`if(!$is_base_pkg) {`
219	`$log->checking(join("",`	219	`$log->checking(join("",`
220	`("for file '",`	220	`("for file '",`
221	`&file_path($pkgname, "DESCRIPTION"),`	221	`&file_path($pkgname, "DESCRIPTION"),`
222	`"'")));`	222	`"'")));`
223	`if(-r &file_path($pkgdir, "DESCRIPTION")) {`	223	`if(-r &file_path($pkgdir, "DESCRIPTION")) {`
224	`$description =`	224	`$description =`
225	`new R::Dcf(&file_path($pkgdir, "DESCRIPTION"));`	225	`new R::Dcf(&file_path($pkgdir, "DESCRIPTION"));`
226	`$log->result("OK");`	226	`$log->result("OK");`
227	`}`	227	`}`
228	`else {`	228	`else {`
229	`$log->result("NO");`	229	`$log->result("NO");`
230	`exit(1);`	230	`exit(1);`
231	`}`	231	`}`
232	`## <NOTE>`	232	`## <NOTE>`
233	`## This check should be adequate, but would not catch a manually`	233	`## This check should be adequate, but would not catch a manually`
234	`## installed package, nor one installed prior to 1.4.0.`	234	`## installed package, nor one installed prior to 1.4.0.`
235	`## </NOTE>`	235	`## </NOTE>`
236	`$log->checking("if this is a source package");`	236	`$log->checking("if this is a source package");`
237	`if(!defined($description->{"Built"})) {`	237	`if(!defined($description->{"Built"})) {`
238	`$log->result("OK")`	238	`$log->result("OK")`
239	`} else {`	239	`} else {`
240	`$log->error();`	240	`$log->error();`
241	`$log->print("Only source packages can be checked.\n");`	241	`$log->print("Only source packages can be checked.\n");`
242	`exit(1);`	242	`exit(1);`
243	`}`	243	`}`
244	`## Option '--no-install' turns off installation and the tests`	244	`## Option '--no-install' turns off installation and the tests`
245	`## which require the package to be installed. When testing`	245	`## which require the package to be installed. When testing`
246	`## recommended packages bundled with R we can skip installation,`	246	`## recommended packages bundled with R we can skip installation,`
247	`## and do so if '--install=skip' was given. If command line`	247	`## and do so if '--install=skip' was given. If command line`
248	`## option '--install' is of the form 'check:FILE', it is assumed`	248	`## option '--install' is of the form 'check:FILE', it is assumed`
249	`## that installation was already performed with stdout/stderr to`	249	`## that installation was already performed with stdout/stderr to`
250	`## FILE, the contents of which need to be checked (without`	250	`## FILE, the contents of which need to be checked (without`
251	`## repeating the installation).`	251	`## repeating the installation).`
252	`## <NOTE>`	252	`## <NOTE>`
253	`## In this case, one also needs to specify where the package`	253	`## In this case, one also needs to specify where the package`
254	`## was installed to using command line option '--library'.`	254	`## was installed to using command line option '--library'.`
255	`## Perhaps we should check for that, although '--install=check'`	255	`## Perhaps we should check for that, although '--install=check'`
256	`## is really only meant for repository maintainers.`	256	`## is really only meant for repository maintainers.`
257	`## </NOTE>`	257	`## </NOTE>`
258	`if($opt_install) {`	258	`if($opt_install) {`
259	`if($opt_install eq "skip") {`	259	`if($opt_install eq "skip") {`
260	`$log->message("skipping installation test");`	260	`$log->message("skipping installation test");`
261	`}`	261	`}`
262	`else {`	262	`else {`
263	`my $use_install_log =`	263	`my $use_install_log =`
264	`(($opt_install =~ /^check/) \|\|`	264	`(($opt_install =~ /^check/) \|\|`
265	`$ENV{"R_CHECK_USE_INSTALL_LOG"} \|\|`	265	`$ENV{"R_CHECK_USE_INSTALL_LOG"} \|\|`
266	`!(-t STDIN && -t STDOUT));`	266	`!(-t STDIN && -t STDOUT));`
267	`my $cmd = "${R::Vars::R_CMD} INSTALL -l ${library}";`	267	`my $cmd = "${R::Vars::R_CMD} INSTALL -l ${library}";`
268	`$cmd .= " --fake" if($opt_install eq "fake");`	268	`$cmd .= " --fake" if($opt_install eq "fake");`
269	`$cmd .= " ${pkgdir}";`	269	`$cmd .= " ${pkgdir}";`
270	`if(!$use_install_log) {`	270	`if(!$use_install_log) {`
271	`## Case A: No redirection of stdout/stderr from`	271	`## Case A: No redirection of stdout/stderr from`
272	`## installation.`	272	`## installation.`
273	`print("\n");`	273	`print("\n");`
274	`if(R_system($cmd)) {`	274	`if(R_system($cmd)) {`
275	`$log->error();`	275	`$log->error();`
276	`$log->print("Installation failed.\n");`	276	`$log->print("Installation failed.\n");`
277	`exit(1);`	277	`exit(1);`
278	`}`	278	`}`
279	`print("\n");`	279	`print("\n");`
280	`}`	280	`}`
281	`else {`	281	`else {`
282	`## Case B. All output from installation redirected,`	282	`## Case B. All output from installation redirected,`
283	`## or already available in the log file.`	283	`## or already available in the log file.`
284	`$log->checking("whether package '$pkgname' " .`	284	`$log->checking("whether package '$pkgname' " .`
285	`"can be installed");`	285	`"can be installed");`
286	`my $out = &file_path($pkgoutdir, "00install.out");`	286	`my $out = &file_path($pkgoutdir, "00install.out");`
287	`my $install_error;`	287	`my $install_error;`
288	`my @lines;`	288	`my @lines;`
289	`if($opt_install =~ /^check/) {`	289	`if($opt_install =~ /^check/) {`
290	`copy(substr($opt_install, 6), $out);`	290	`copy(substr($opt_install, 6), $out);`
291	`$opt_install = "check";`	291	`$opt_install = "check";`
292	`@lines = &read_lines($out);`	292	`@lines = &read_lines($out);`
293	`$install_error =`	293	`$install_error =`
294	`($lines[$#lines] !~ /^\* DONE/);`	294	`($lines[$#lines] !~ /^\* DONE/);`
295	`}`	295	`}`
296	`else {`	296	`else {`
297	`$cmd .= " > $out 2>&1";`	297	`$cmd .= " > $out 2>&1";`
298	`$install_error = &R_system($cmd);`	298	`$install_error = &R_system($cmd);`
299	`}`	299	`}`
300	`if($install_error) {`	300	`if($install_error) {`
301	`$log->error();`	301	`$log->error();`
302	`$log->print("Installation failed.\n");`	302	`$log->print("Installation failed.\n");`
303	`$log->print("See '$out' for details.\n");`	303	`$log->print("See '$out' for details.\n");`
304	`exit(1);`	304	`exit(1);`
305	`}`	305	`}`
306	`## There could still be some important warnings that`	306	`## There could still be some important warnings that`
307	`## we'd like to report. For the time being, start`	307	`## we'd like to report. For the time being, start`
308	`## with compiler warnings about non ISO C code (Or`	308	`## with compiler warnings about non ISO C code (Or`
309	`## at least, what looks like it.) In theory, we`	309	`## at least, what looks like it.) In theory, we`
310	`## should only do this when using GCC ...`	310	`## should only do this when using GCC ...`
311	`@lines = &read_lines($out)`	311	`@lines = &read_lines($out)`
312	`unless($opt_install eq "check");`	312	`unless($opt_install eq "check");`
313	`my $warn_re =`	313	`my $warn_re =`
314	`"(" . join("\|", ("^WARNING:",`	314	`"(" . join("\|", ("^WARNING:",`
315	`"^Warning:",`	315	`"^Warning:",`
316	`": warning: .*ISO C",`	316	`": warning: .*ISO C",`
317	`"missing link\\(s\\):")) . ")";`	317	`"missing link\\(s\\):")) . ")";`
318	`@lines = grep(/$warn_re/, @lines);`	318	`@lines = grep(/$warn_re/, @lines);`
319	`if(scalar(@lines) > 0) {`	319	`if(scalar(@lines) > 0) {`
320	`$log->warning();`	320	`$log->warning();`
321	`$log->print("Found the following " .`	321	`$log->print("Found the following " .`
322	`"significant warnings:\n");`	322	`"significant warnings:\n");`
323	`$log->print(" " . join("\n ", @lines) . "\n");`	323	`$log->print(" " . join("\n ", @lines) . "\n");`
324	`}`	324	`}`
325	`else {`	325	`else {`
326	`$log->result("OK");`	326	`$log->result("OK");`
327	`}`	327	`}`
328	`}`	328	`}`
329	`}`	329	`}`
330	`}`	330	`}`
331		331
332	`}`	332	`}`
333		333
334	`my $is_bundle = 0;`	334	`my $is_bundle = 0;`
335	`if($description->{"Contains"}) {`	335	`if($description->{"Contains"}) {`
336	`$log->message("looks like '${pkgname}' is a package bundle");`	336	`$log->message("looks like '${pkgname}' is a package bundle");`
337	`$is_bundle = 1;`	337	`$is_bundle = 1;`
338	`my @bundlepkgs = split(/\s+/, $description->{"Contains"});`	338	`my @bundlepkgs = split(/\s+/, $description->{"Contains"});`
339	`foreach my $ppkg (@bundlepkgs) {`	339	`foreach my $ppkg (@bundlepkgs) {`
340	`$log->message("checking '$ppkg' in bundle '$pkgname'");`	340	`$log->message("checking '$ppkg' in bundle '$pkgname'");`
341	`$log->setstars("**");`	341	`$log->setstars("**");`
342	`chdir($startdir);`	342	`chdir($startdir);`
343	`check_pkg(&file_path($pkgdir, $ppkg), $pkgoutdir, $startdir,`	343	`check_pkg(&file_path($pkgdir, $ppkg), $pkgoutdir, $startdir,`
344	`$library, $is_bundle, $description, $log,`	344	`$library, $is_bundle, $description, $log,`
345	`$is_base_pkg);`	345	`$is_base_pkg);`
346	`$log->setstars("*");`	346	`$log->setstars("*");`
347	`}`	347	`}`
348	`}`	348	`}`
349	`else {`	349	`else {`
350	`$is_bundle = 0;`	350	`$is_bundle = 0;`
351	`chdir($startdir);`	351	`chdir($startdir);`
352	`check_pkg($pkgdir, $pkgoutdir, $startdir, $library,`	352	`check_pkg($pkgdir, $pkgoutdir, $startdir, $library,`
353	`$is_bundle, $description, $log, $is_base_pkg);`	353	`$is_bundle, $description, $log, $is_base_pkg);`
354	`}`	354	`}`
355		355
356	`if($log->{"warnings"}) {`	356	`if($log->{"warnings"}) {`
357	`print("\n") ;`	357	`print("\n") ;`
358	`$log->summary();`	358	`$log->summary();`
359	`}`	359	`}`
360	`$log->close();`	360	`$log->close();`
361	`print("\n");`	361	`print("\n");`
362	`}`	362	`}`
363		363
364		364
365	`sub check_pkg {`	365	`sub check_pkg {`
366		366
367	`my ($pkg, $pkgoutdir, $startdir, $library,`	367	`my ($pkg, $pkgoutdir, $startdir, $library,`
368	`$in_bundle, $description, $log, $is_base_pkg) = @_;`	368	`$in_bundle, $description, $log, $is_base_pkg) = @_;`
369	`my ($pkgdir, $pkgname);`	369	`my ($pkgdir, $pkgname);`
370		370
371	`## $pkg is the argument we received from the main loop.`	371	`## $pkg is the argument we received from the main loop.`
372	`## $pkgdir is the corresponding absolute path,`	372	`## $pkgdir is the corresponding absolute path,`
373	`## $pkgname the name of the package.`	373	`## $pkgname the name of the package.`
374	`## Note that we need to do repeat the checking from the main loop in`	374	`## Note that we need to do repeat the checking from the main loop in`
375	`## the case of package bundles (and we could check for this).`	375	`## the case of package bundles (and we could check for this).`
376		376
377	`$log->checking("package directory");`	377	`$log->checking("package directory");`
378	`chdir($startdir);`	378	`chdir($startdir);`
379	`$pkg =~ s/\/$//;`	379	`$pkg =~ s/\/$//;`
380	`if(-d $pkg) {`	380	`if(-d $pkg) {`
381	`chdir($pkg)`	381	`chdir($pkg)`
382	`or die "Error: cannot change to directory '$pkg'\n";`	382	`or die "Error: cannot change to directory '$pkg'\n";`
383	`$pkgdir = R_cwd();`	383	`$pkgdir = R_cwd();`
384	`$pkgname = basename($pkgdir);`	384	`$pkgname = basename($pkgdir);`
385	`}`	385	`}`
386	`else {`	386	`else {`
387	`$log->error();`	387	`$log->error();`
388	`$log->print("Package directory '$pkg' does not exist.\n");`	388	`$log->print("Package directory '$pkg' does not exist.\n");`
389	`exit(1);`	389	`exit(1);`
390	`}`	390	`}`
391	`$log->result("OK");`	391	`$log->result("OK");`
392		392
393	`chdir($pkgdir);`	393	`chdir($pkgdir);`
394		394
395	`## Build list of exclude patterns.`	395	`## Build list of exclude patterns.`
396		396
397	`my @exclude_patterns = R::Utils::get_exclude_patterns();`	397	`my @exclude_patterns = R::Utils::get_exclude_patterns();`
398	`## <FIXME>`	398	`## <FIXME>`
399	`## This is not right for bundles where the build ignore pattern`	399	`## This is not right for bundles where the build ignore pattern`
400	`## file is in the top-level bundle dir. We could fix this by`	400	`## file is in the top-level bundle dir. We could fix this by`
401	`## using '../.Rbuildignore' instead, but then e.g.`	401	`## using '../.Rbuildignore' instead, but then e.g.`
402	`## find(\&find_wrong_perms_A, ".");`	402	`## find(\&find_wrong_perms_A, ".");`
403	`## find(\&find_wrong_perms_B, ".");`	403	`## find(\&find_wrong_perms_B, ".");`
404	`## are wrong because the exclude patterns are relative to '..'.`	404	`## are wrong because the exclude patterns are relative to '..'.`
405	`if(-f "./.Rbuildignore") {`	405	`if(-f "./.Rbuildignore") {`
406	`open(RBUILDIGNORE, "./.Rbuildignore");`	406	`open(RBUILDIGNORE, "./.Rbuildignore");`
407	`while(<RBUILDIGNORE>) {`	407	`while(<RBUILDIGNORE>) {`
408	`chop;`	408	`chop;`
409	`push(@exclude_patterns, $_) if $_;`	409	`push(@exclude_patterns, $_) if $_;`
410	`}`	410	`}`
411	`close(RBUILDIGNORE);`	411	`close(RBUILDIGNORE);`
412	`}`	412	`}`
413	`## </FIXME>`	413	`## </FIXME>`
414		414
415	`## Check for portable file names.`	415	`## Check for portable file names.`
416		416
417	`## Ensure that the names of the files in the package are valid for`	417	`## Ensure that the names of the files in the package are valid for`
418	`## at least the supported OS types. Under Unix, we definitely`	418	`## at least the supported OS types. Under Unix, we definitely`
419	`## cannot have '/'; under Windows, the control characters as well as`	419	`## cannot have '/'; under Windows, the control characters as well as`
420	`## " * : < > ? \ \|`	420	`## " * : < > ? \ \|`
421	`## (i.e., ASCII characters 1 to 31 and 34, 36, 58, 60, 62, 63, 92,`	421	`## (i.e., ASCII characters 1 to 31 and 34, 36, 58, 60, 62, 63, 92,`
422	`## and 124) are or can be invalid. (In addition, one cannot have`	422	`## and 124) are or can be invalid. (In addition, one cannot have`
423	`## one-character file names consisting of just ' ', '.', or '~'.)`	423	`## one-character file names consisting of just ' ', '.', or '~'.)`
424	`## Based on information by Uwe Ligges, Duncan Murdoch, and Brian`	424	`## Based on information by Uwe Ligges, Duncan Murdoch, and Brian`
425	`## Ripley.`	425	`## Ripley.`
426		426
427	`## Furthermore, Uwe Ligges says that Windows still does not allow`	427	`## Furthermore, Uwe Ligges says that Windows still does not allow`
428	`## the following DOS device names (by themselves or with possible`	428	`## the following DOS device names (by themselves or with possible`
429	`## extensions):`	429	`## extensions):`
430	`##`	430	`##`
431	`## Name Function`	431	`## Name Function`
432	`## ---- --------`	432	`## ---- --------`
433	`## CON Keyboard and display`	433	`## CON Keyboard and display`
434	`## PRN System list device, usually a parallel port`	434	`## PRN System list device, usually a parallel port`
435	`## AUX Auxiliary device, usually a serial port`	435	`## AUX Auxiliary device, usually a serial port`
436	`## CLOCK$ System real-time clock`	436	`## CLOCK$ System real-time clock`
437	`## NUL Bit-bucket device`	437	`## NUL Bit-bucket device`
438	`## COM1 First serial communications port`	438	`## COM1 First serial communications port`
439	`## COM2 Second serial communications port`	439	`## COM2 Second serial communications port`
440	`## COM3 Third serial communications port`	440	`## COM3 Third serial communications port`
441	`## COM4 Fourth serial communications port`	441	`## COM4 Fourth serial communications port`
442	`## LPT1 First parallel printer port`	442	`## LPT1 First parallel printer port`
443	`## LPT2 Second parallel printer port`	443	`## LPT2 Second parallel printer port`
444	`## LPT3 Third parallel printer port`	444	`## LPT3 Third parallel printer port`
445		445
446	`$log->checking("for portable file names");`	446	`$log->checking("for portable file names");`
447	`my @bad_files = ();`	447	`my @bad_files = ();`
448	`sub find_wrong_names {`	448	`sub find_wrong_names {`
449	`my $file_path = $File::Find::name;`	449	`my $file_path = $File::Find::name;`
450	`$file_path =~ s/^[^\/]*\///;`	450	`$file_path =~ s/^[^\/]*\///;`
451	`foreach my $p (@exclude_patterns) {`	451	`foreach my $p (@exclude_patterns) {`
452	`if($WINDOWS) {`	452	`if($WINDOWS) {`
453	`## Argh: Windows is case-honoring but not`	453	`## Argh: Windows is case-honoring but not`
454	`## case-insensitive ...`	454	`## case-insensitive ...`
455	`return 0 if($file_path =~ /$p/i);`	455	`return 0 if($file_path =~ /$p/i);`
456	`}`	456	`}`
457	`else {`	457	`else {`
458	`return 0 if($file_path =~ /$p/);`	458	`return 0 if($file_path =~ /$p/);`
459	`}`	459	`}`
460	`}`	460	`}`
461	`my $file_name = basename($file_path);`	461	`my $file_name = basename($file_path);`
462	`if(grep(/[[:cntrl:]\"\*\/\:\<\>\?\\\\|]/, $file_name)) {`	462	`if(grep(/[[:cntrl:]\"\*\/\:\<\>\?\\\\|]/, $file_name)) {`
463	`push(@bad_files, $file_path);`	463	`push(@bad_files, $file_path);`
464	`}`	464	`}`
465	`else {`	465	`else {`
466	`$file_name =~ tr/A-Z/a-z/;`	466	`$file_name =~ tr/A-Z/a-z/;`
467	`$file_name =~ s/\..*//;`	467	`$file_name =~ s/\..*//;`
468	`push(@bad_files, $file_path)`	468	`push(@bad_files, $file_path)`
469	`if(grep(/^(con\|prn\|aux\|clock\$\|nul\|lpt[1-3]\|com[1-4])$/,`	469	`if(grep(/^(con\|prn\|aux\|clock\$\|nul\|lpt[1-3]\|com[1-4])$/,`
470	`$file_name));`	470	`$file_name));`
471	`}`	471	`}`
472	`}`	472	`}`
473	`find(\&find_wrong_names, ".");`	473	`find(\&find_wrong_names, ".");`
474	`if($#bad_files >= 0) {`	474	`if($#bad_files >= 0) {`
475	`$log->error();`	475	`$log->error();`
476	`$log->print("Found the following files with " .`	476	`$log->print("Found the following files with " .`
477	`"non-portable file names:\n");`	477	`"non-portable file names:\n");`
478	`$log->print(" " . join("\n ", @bad_files) . "\n");`	478	`$log->print(" " . join("\n ", @bad_files) . "\n");`
479	`$log->print(wrap("", "",`	479	`$log->print(wrap("", "",`
480	`("These are not valid file names",`	480	`("These are not valid file names",`
481	`"on all R platforms.\n",`	481	`"on all R platforms.\n",`
482	`"Please rename the files and try again.\n",`	482	`"Please rename the files and try again.\n",`
483	`"See section 'Package structure'",`	483	`"See section 'Package structure'",`
484	`"in manual 'Writing R Extensions'.\n")));`	484	`"in manual 'Writing R Extensions'.\n")));`
485	`exit(1);`	485	`exit(1);`
486	`}`	486	`}`
487		487
488	`$log->result("OK");`	488	`$log->result("OK");`
489		489
490	`## Check for sufficient file permissions (Unix only).`	490	`## Check for sufficient file permissions (Unix only).`
491		491
492	`## This used to be much more 'aggressive', requiring that dirs and`	492	`## This used to be much more 'aggressive', requiring that dirs and`
493	`## files have mode >= 00755 and 00644, respectively (with an error`	493	`## files have mode >= 00755 and 00644, respectively (with an error`
494	`## if not), and that files know to be 'text' have mode 00644 (with a`	494	`## if not), and that files know to be 'text' have mode 00644 (with a`
495	`## warning if not). We now only require that dirs and files have`	495	`## warning if not). We now only require that dirs and files have`
496	`## mode >= 00700 and 00400, respectively, and try to fix`	496	`## mode >= 00700 and 00400, respectively, and try to fix`
497	`## insufficient permission in the INSTALL code (Unix only).`	497	`## insufficient permission in the INSTALL code (Unix only).`
498	`##`	498	`##`
499	`## In addition, we check whether files 'configure' and 'cleanup'`	499	`## In addition, we check whether files 'configure' and 'cleanup'`
500	`## exists in the top-level directory but are not executable, which`	500	`## exists in the top-level directory but are not executable, which`

The R Project SVN R

(root)/trunk/src/scripts/check.in @ 28362 – Rev 28220 → 28240