#! @PERL@ #-*- perl -*- # Copyright (C) 2000-2002 R Development Core Team # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # A copy of the GNU General Public License is available via WWW at # http://www.gnu.org/copyleft/gpl.html. You can also obtain it by # writing to the Free Software Foundation, Inc., 59 Temple Place, # Suite 330, Boston, MA 02111-1307 USA. # Send any bug reports to r-bugs@r-project.org use Cwd; use File::Basename; use File::Copy; use File::Find; use File::Path; use Getopt::Long; use R::Dcf; use R::Logfile; use R::Rdtools; use R::Utils; use R::Vars; use Text::DelimMatch; use Text::Wrap; ## don't buffer output $| = 1; my $revision = ' $Revision: 1.133.2.1 $ '; my $version; my $name; $revision =~ / ([\d\.]*) /; $version = $1; ($name = $0) =~ s|.*/||; ## Options my $opt_clean = 1; my $opt_examples = 1; my $opt_tests = 1; my $opt_latex = 1; my $opt_use_gct = 0; my $opt_codoc = 1; my $opt_perms = 1; my $opt_install = 1; my $opt_vignettes = 1; my $WINDOWS = ($R::Vars::OSTYPE eq "windows"); R::Vars::error("R_HOME", "R_CMD", "R_EXE"); my @known_options = ("help|h", "version|v", "outdir|o:s", "library|l:s", "no-clean", "no-examples", "no-tests", "no-latex", "use-gct" => \$opt_use_gct, "no-codoc", "no-perms", "no-install", "no-vignettes"); GetOptions(@known_options) or usage(); R_version("R add-on package checker", $version) if $opt_version; usage() if $opt_help; $opt_clean = 0 if $opt_no_clean; $opt_examples = 0 if $opt_no_examples; $opt_tests = 0 if $opt_no_tests; $opt_latex = 0 if $opt_no_latex; $opt_codoc = 0 if $opt_no_codoc; $opt_perms = 0 if $opt_no_perms; $opt_install = 0 if $opt_no_install; $opt_vignettes = 0 if $opt_no_vignettes; my $startdir = cwd(); $opt_outdir = $startdir unless $opt_outdir; chdir($opt_outdir) or die "Error: cannot change to directory '$opt_outdir'\n"; my $outdir = cwd(); chdir($startdir); my $R_LIBS = $ENV{'R_LIBS'}; my $library; if($opt_library) { chdir($opt_library) or die "Error: cannot change to directory '$opt_library'\n"; $library = cwd(); $ENV{'R_LIBS'} = env_path($library, $R_LIBS); chdir($startdir); } my $R_opts = "--vanilla"; if($opt_latex) { my $log = new R::Logfile(); $log->checking("for working latex"); open(TEXFILE, "> " . &file_path(${R::Vars::TMPDIR}, "Rtextest$$.tex")) or die "Error: cannot write to Rtextest$$.tex\n"; print TEXFILE "\\documentclass\{article\}\\begin\{document\}" . "test\\end\{document\}\n"; close(TEXFILE); chdir($R::Vars::TMPDIR); if(R_system("${R::Vars::LATEX} Rtextest$$ > Rtextest$$.out")) { $log->result("NO"); $HAVE_LATEX = 0; } else { $log->result("OK"); $HAVE_LATEX = 1; } unlink(); chdir($startdir); $log->close(); } ## get the valid keywords for later ... my %standard_keywords = (); open(KEYWORDS, "< " . &file_path(${R::Vars::R_HOME}, "doc", "KEYWORDS.db")) or die "Error: cannot open 'KEYWORDS.db'"; while() { if(/^.*\|([^:]*):.*/) { $standard_keywords{$1} = 1; } } close(KEYWORDS); ## ## We now always redefine T/F when running the examples, but warn about ## an empty R_CHECK_WITH_T_N_F_AS_NULL environment variable intended to ## disable the redefinition. ## Remove this eventually, and also the test in massage-Examples.pl. if(defined($ENV{'R_CHECK_WITH_T_N_F_AS_NULL'}) && $ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} eq "") { my $log = new R::Logfile(); $log->message("redefining R_CHECK_WITH_T_N_F_AS_NULL to 'yes'"); $log->close(); } $ENV{'R_CHECK_WITH_T_N_F_AS_NULL'} = "yes"; ## This is the main loop over all packages to be checked. ($#ARGV >= 0) or die "Error: no packages were specified"; foreach my $pkg (@ARGV) { ## $pkg should be the path to the package (bundle) root source ## directory, either absolute or relative to $startdir. ## $pkgdir is the corresponding absolute path. ## $pkgname is the name of the package (bundle). chdir($startdir); $pkg =~ s/\/$//; (-d $pkg) or die "Error: package dir '$pkg' does not exist"; chdir($pkg) or die "Error: cannot change to directory '$pkg'\n"; my $pkgdir = cwd(); my $pkgname = basename($pkgdir); chdir($startdir); my $pkgoutdir = &file_path($outdir, "$pkgname.Rcheck"); rmtree($pkgoutdir) if ($opt_clean && (-d $pkgoutdir)) ; if(!(-d $pkgoutdir)) { mkdir($pkgoutdir, 0755) or die("Error: cannot create directory '$pkgoutdir'\n"); } $log = new R::Logfile(&file_path($pkgoutdir, "00check.log")); $log->message("using log directory '$pkgoutdir'"); if(!$opt_library) { $library = $pkgoutdir; $ENV{'R_LIBS'} = env_path($library, $R_LIBS); } my $description; my $is_base_pkg = 0; ## Package sources from the R distribution are special. They have a ## 'DESCRIPTION.in' file (instead of 'DESCRIPTION'), with Version ## field containing '@VERSION@' for substitution by configure. We ## test for such packages by looking for 'DESCRIPTION.in' with ## Priority 'base', and skip the installation test for such ## packages. if(-r &file_path($pkgdir, "DESCRIPTION.in")) { $description = new R::Dcf(&file_path($pkgdir, "DESCRIPTION.in")); if($description->{"Priority"} eq "base") { $log->message("looks like '${pkgname}' is a base package"); $log->message("skipping installation test"); $is_base_pkg = 1; } } if(!$is_base_pkg) { $log->checking(join("", ("for file '", &file_path($pkgname, "DESCRIPTION"), "'"))); if(-r &file_path($pkgdir, "DESCRIPTION")) { $description = new R::Dcf(&file_path($pkgdir, "DESCRIPTION")); $log->result("OK"); } else { $log->result("NO"); exit(1); } ## ## This check should be adequate, but would not catch a manually ## installed package, nor one installed prior to 1.4.0. ## $log->checking("if this is a source package"); if(!defined($description->{"Built"})) { $log->result("OK") } else { $log->error(); $log->print("Only *source* packages can be checked.\n"); exit(1); } if($opt_install) { print("\n"); my $cmd = "${R::Vars::R_CMD} INSTALL -l $library $pkgdir"; if(R_system($cmd)) { $log->error(); $log->print("Installation failed.\n"); exit(1); } print("\n"); } } my $is_bundle = 0; if($description->{"Contains"}) { $log->message("looks like '${pkgname}' is a package bundle"); $is_bundle = 1; my @bundlepkgs = split(/\s+/, $description->{"Contains"}); foreach my $ppkg (@bundlepkgs) { $log->message("checking '$ppkg' in bundle '$pkgname'"); $log->setstars("**"); chdir($startdir); check_pkg(&file_path($pkgdir, $ppkg), $pkgoutdir, $startdir, $library, $is_bundle, $description, $log, $is_base_pkg); $log->setstars("*"); } } else { $is_bundle = 0; chdir($startdir); check_pkg($pkgdir, $pkgoutdir, $startdir, $library, $is_bundle, $description, $log, $is_base_pkg); } if($log->{"warnings"}) { print("\n") ; $log->summary(); } $log->close(); print("\n"); } sub check_pkg { my ($pkg, $pkgoutdir, $startdir, $library, $in_bundle, $description, $log, $is_base_pkg) = @_; my ($pkgdir, $pkgname); ## $pkg is the argument we received from the main loop. ## $pkgdir is the corresponding absolute path, ## $pkgname the name of the package. ## Note that we need to do repeat the checking from the main loop in ## the case of package bundles (and we could check for this). $log->checking("package directory"); chdir($startdir); $pkg =~ s/\/$//; if(-d $pkg) { chdir($pkg) or die "Error: cannot change to directory '$pkg'\n"; $pkgdir = cwd(); $pkgname = basename($pkgdir); } else { $log->error(); $log->print("Package directory '$pkg' does not exist.\n"); exit(1); } $log->result("OK"); chdir($pkgdir); ## Check for sufficient file permissions (Unix only). ## This is a bit controversial, and hence there is a command line ## option '--no-perms' to turn this off. In fact, the code below ## does a bit too much. ## What would really be needed is the following: ## * All dirs or files must be at least 555 or 444, respectively. ## * Everything that gets installed must be writeable. This ## includes ## DESCRIPTION COPYING INDEX NAMESPACE ## data/* demo/* exec/* inst/*. ## * All directories used for building 'objects' must be at least ## 755. This includes '.' and src. ## Given time, the above could be implemented. if($opt_perms && ($R::Vars::OSTYPE eq "unix")) { $log->checking("for sufficient/correct file permissions"); my @bad_files = (); my @excludepatterns = R::Utils::get_exclude_patterns(); ## ## This is not right for bundles where the build ignore pattern ## file is in the top-level bundle dir. We could fix this by ## using '../.Rbuildignore' instead, but then ## find(\&find_wrong_perms_A, "."); ## find(\&find_wrong_perms_B, "."); ## are wrong because the exclude patterns are relative to '..'. if(-f "./.Rbuildignore") { open(RBUILDIGNORE, "./.Rbuildignore"); while() { chop; push(@exclude_patterns, $_) if $_; } close(RBUILDIGNORE); } ## ## Phase A. Directories at least 755, files at least 644. sub find_wrong_perms_A { my $filename = $File::Find::name; $filename =~ s/^[^\/]*\///; foreach my $p (@exclude_patterns) { if($WINDOWS) { ## Argh: Windows is case-honoring but not ## case-insensitive ... return 0 if($filename =~ /$p/i); } else { return 0 if($filename =~ /$p/); } } if(-d $_ && (((stat $_)[2] & 00755) < oct("755"))) { push(@bad_files, $File::Find::name); } if(-f $_ && (((stat $_)[2] & 00644) < oct("644"))) { push(@bad_files, $File::Find::name); } } find(\&find_wrong_perms_A, "."); if($#bad_files >= 0) { $log->error(); $log->print("Found the following files with " . "insufficient permissions:\n"); $log->print(" " . join("\n ", @bad_files) . "\n"); $log->print(wrap("", "", ("Permissions should be at least 755", "for directories and 644 for files.\n"))); $log->print("Please fix permissions and try again.\n"); exit(1); } ## Phase B. Text files (as determined by their extensions) ## should really be mode 644. @bad_files = (); my @textfile_patterns = ("\\.[RSdqr]\$", # R source code "\\.[Rr]d\$", # Rd files "\\.([Ccfh]|cc|cpp)\$", # C/C++/FORTRAN sources and headers "^(DESCRIPTION|COPYING|INDEX|NAMESPACE|README)\$"); sub find_wrong_perms_B { my $filename = $File::Find::name; $filename =~ s/^[^\/]*\///; foreach my $p (@exclude_patterns) { return 0 if($filename =~ /$p/); } if(-f $_ && (((stat $_)[2] & 00777) != oct("644"))) { foreach my $p (@textfile_patterns) { if($filename =~ /$p/) { push(@bad_files, $File::Find::name); last; } } } } find(\&find_wrong_perms_B, "."); if($#bad_files >= 0) { $log->warning(); $log->print("Found the following text files with " . "incorrect permissions:\n"); $log->print(" " . join("\n ", @bad_files) . "\n"); $log->print(wrap("", "", ("Permissions for text files", "(including R, Rd, and C/C++/FORTRAN", "sources) should be exactly 644.\n"))); $log->print("Please fix permissions.\n"); } else { $log->result("OK"); } } ## Check DESCRIPTION meta-information. if($in_bundle) { # join DESCRIPTION and DESCRIPTION.in if(-r "DESCRIPTION.in") { $log->checking("for file 'DESCRIPTION.in'"); my $description_in = new R::Dcf("DESCRIPTION.in"); foreach my $key (keys(%$description)) { $description_in->{$key} = $description->{$key}; } ## From now on use $description_in instead of $description ## in this subroutine. $description = $description_in; $log->result("OK"); $log->message("joining DESCRIPTION and DESCRIPTION.in"); } else { $log->result("NO"); exit(1); } } my @msg_DESCRIPTION = ("See the information on DESCRIPTION files", "in section 'Creating R packages'", "of the 'Writing R Extensions' manual.\n"); $log->checking("DESCRIPTION meta-information"); ## Mandatory entries in DESCRIPTION: ## Package, Version, License, Description, Title, Author, ## Maintainer. foreach my $field (qw(Package Version License Description Title Author Maintainer)) { if(!$description->{$field}) { $log->error(); $log->print("No DESCRIPTION $field field found.\n"); $log->print(wrap("", "", @msg_DESCRIPTION)); exit(1); } } if($description->{"Package"} !~ /^[a-z][a-z\d\.]*$/i) { $log->error(); $log->print("Malformed package name.\n"); $log->print(wrap("", "", @msg_DESCRIPTION)); exit(1); } if($description->{"Package"} ne $pkgname) { $log->error(); $log->print("DESCRIPTION Package field differs from dir name.\n"); $log->print(wrap("", "", @msg_DESCRIPTION)); exit(1); } if(($description->{"Version"} !~ /^\d+([.-]\d+)+$/) && !$is_base_pkg) { ## Package sources from the R distribution have '@VERSION@' in ## their 'DESCRIPTION.in' files ... $log->error(); $log->print("Malformed package version.\n"); $log->print(wrap("", "", @msg_DESCRIPTION)); exit(1); } if($description->{"Maintainer"} !~ /^[^<>]*<[^<>]+> *$/) { $log->error(); $log->print("Malformed Maintainer field.\n"); $log->print(wrap("", "", @msg_DESCRIPTION)); exit(1); } ## Optional entries in DESCRIPTION: ## Depends. ## These must be correct if present. if($description->{"Depends"}) { my @dependencies = split(/\,\s*/, $description->{"Depends"}); my @matches; my ($is_bad_dep_op, $is_bad_dep_version); my ($bad_dep_value, @bad_dep_error); foreach my $dep (@dependencies) { @matches = ($dep =~ /^\s*([\w\.]+)(\s*\(([^) ]+)\s+([^) ]+)\))?\s*$/); ## The entry is malformed if there is no match, or there is ## a match but the dep_op is different from '<=' or '>', or ## the dep_version does not only consist of digits, '.' or ## '-'. $is_bad_dep_op = (($matches[2] ne "<=") && ($matches[2] ne ">=")); $is_bad_dep_version = ($matches[3] =~ /[^\d\.\-]/); if(!($matches[0]) || ($matches[1] && ($is_bad_dep_op || $is_bad_dep_version))) { $bad_dep_entry = $dep; if(!($matches[0])) { @bad_dep_error = ("Entries must be names of packages, optionally", "followed by '<=' or '>=', white space, and a", "valid version number in parentheses.\n"); } elsif($is_bad_dep_op) { @bad_dep_error = ("Infeasible comparison operator '$matches[2]'.\n", "Only operators '<=' and '>=' are possible.\n"); } elsif($is_bad_dep_version) { @bad_dep_error = ("Infeasible version number '$matches[3]'.\n", "Version numbers must only contain digits,", "'.' or '-'.\n"); } break; } } if($bad_dep_entry) { $log->error(); $log->print("Malformed Depends field.\n"); $log->print("Offending entry is: '$bad_dep_entry'.\n"); $log->print(wrap("", "", @bad_dep_error)); $log->print(wrap("", "", @msg_DESCRIPTION)); exit(1); } } $log->result("OK"); ## Try figuring out whether the package dependencies can be resolved ## at run time. Ideally, the installation mechanism would do this, ## and we also do not check versions ... ## ## Need to do this here because we need the 'real' DESCRIPTION file ## (also in the case of bundles), and to know that its 'Depends' ## field is syntactically correct. if($description->{"Depends"} && $opt_install) { $log->checking("package dependencies"); my @required_packages = (); my @dependencies = split(/\,/, $description->{"Depends"}); foreach my $dep (@dependencies) { $dep =~ s/^\s*([\w\.]+).*$/\1/; next if($dep eq "R"); push(@required_packages, $dep); } if($#required_packages >= 0) { my $Rcmd = "requiredPackages <- c(\""; $Rcmd .= join("\", \"", @required_packages); $Rcmd .= "\")\n"; $Rcmd .= "writeLines(requiredPackages[!requiredPackages %in% "; $Rcmd .= "installed.packages()[ , \"Package\"]])\n"; my @out = R_runR($Rcmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { $log->error(); $log->print("Packages required but not available:\n"); $log->print(wrap(" ", " ", @out) . "\n"); exit(1); } } $log->result("OK"); } ## Check index information. $log->checking("index information"); my @msg_index = ("See the information on INDEX files and package", "subdirectories in section 'Creating R packages'", "of the 'Writing R Extensions' manual.\n"); my $any = 0; if(-z "INDEX") { ## If there is an empty INDEX file, we get no information about ## the package contents ... $any++; $log->warning(); $log->print("Empty file 'INDEX'.\n"); } if((-d "demo") && &list_files_with_type("demo", "demo")) { my $index = &file_path("demo", "00Index"); if(!(-s $index)) { $log->warning() unless($any); $any++; $log->print("Empty or missing file '$index'.\n"); } else { my $dir = "demo"; my $cmd = "library(tools)\n"; $cmd .= ".checkDemoIndex(\"$dir\")\n"; my @out = R_runR($cmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { $log->warning() unless($any); $any++; $log->print(join("\n", @out) . "\n"); } } } if((-d &file_path("inst", "doc")) && &list_files_with_type(&file_path("inst", "doc"), "vignette")) { my $dir = &file_path("inst", "doc"); my $cmd = "library(tools)\n"; $cmd .= ".checkVignetteIndex(\"$dir\")\n"; my @out = R_runR($cmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { $log->warning() unless($any); $any++; $log->print(join("\n", @out) . "\n"); } } if($any) { $log->print(wrap("", "", @msg_index)); } else { $log->result("OK"); } ## Check package subdirectories. if((-d "data") || (-d "demo") || (-d "src") || (-d "inst")) { $log->checking("package subdirectories"); my $any; ## Subdirectory 'data' without data sets? if((-d "data") && !&list_files_with_type("data", "data")) { $log->warning() unless $any; $any++; $log->print("Subdirectory 'data' contains no data sets.\n"); } ## Subdirectory 'demo' without demos? if((-d "demo") && !&list_files_with_type("demo", "demo")) { $log->warning() unless $any; $any++; $log->print("Subdirectory 'demo' contains no demos.\n"); } ## Subdirectory 'src' without sources? ## ## If there is a Makefile (or a Makefile.win), we cannot assume ## that source files have the predefined extensions. ## 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"); ## ## We could/should really check *all* OS specific subdirs here. my @R_files = &list_files_with_type("R", "code"); ## 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. ## ## We could/should really check all OS specific subdirs here. @R_files = &list_files_with_type("R", "code"); ## } my $any = 0; my $ext; foreach my $file (@R_files) { last if $any; open(FILE, "< $file") or die "Error: cannot open file '$file' for reading"; while() { if(/library.dynam\(\"(.*?)\"/o) { my $arg = $1; if($arg =~ /\.(so|sl|dll)$/) { $ext = $1; $any++; last; } } } close(FILE); } if($any == 0) { $log->result("OK"); } else { $log->error(); $log->print("library.dynam() used with extension '.$ext'.\n"); $log->print(wrap("", "", ("The system-specific extension for", "shared libraries should not be added.\n"))); $log->print("See ?library.dynam\n"); exit(1); } } ## Check whether methods have all arguments of the corresponding ## generic. if(-d "R") { $log->checking("generic/method consistency"); my $Rcmd = "library(tools)\n"; if($opt_install) { $Rcmd .= "checkMethods(package = \"${pkgname}\")\n"; } else { $Rcmd .= "checkMethods(dir = \"${pkgdir}\")\n"; } my @out = R_runR($Rcmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { $log->warning(); $log->print(join("\n", @out) . "\n"); } else { $log->result("OK"); } } ## Check whether assignment functions have their final argument ## named 'value'. if(-d "R") { $log->checking("for assignment functions with final arg not " . "named 'value'"); my $Rcmd = "library(tools)\n"; if($opt_install) { $Rcmd .= "checkAssignFuns(package = \"${pkgname}\")\n"; } else { $Rcmd .= "checkAssignFuns(dir = \"${pkgdir}\")\n"; } my @out = R_runR($Rcmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { ## ## We really want to stop if we find offending assignment ## functions. But we cannot use error() because output may ## contain warnings ... $log->warning(); ## $log->print(join("\n", @out) . "\n"); } else { $log->result("OK"); } } ## Check foreign function calls. if((-d "R") && $ENV{'R_CHECK_FF_CALLS'}) { $log->checking("foreign function calls"); my $Rcmd = "library(tools)\n"; if($opt_install) { $Rcmd .= "checkFF(package = \"${pkgname}\")\n"; } else { $Rcmd .= "checkFF(dir = \"${pkgdir}\")\n"; } my @out = R_runR($Rcmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { $log->warning(); $log->print(join("\n", @out) . "\n"); } else { $log->result("OK"); } } ## Check R documentation files. if(-d "man") { $log->checking("Rd files"); my @Rd_files = &list_files_with_type("man", "docs", $R::Vars::OSTYPE); ## Rd files with illegal file names? my @bad_files = grep(/= 0) { $log->error(); $log->print("Cannot handle Rd file names containing '<'.\n" . "These are not legal file names on all R " . "platforms.\n" . "Please rename the following files and " . "try again:\n"); $log->print(" " . join("\n ", @bad_files) . "\n"); exit(1); } @Rd_files = sort(@Rd_files); ## ## 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 ... ## my @mandatory_tags = qw(name alias title description keyword); my @unique_tags = qw(name title description usage arguments format details value references source seealso examples note author synopsis); my @bad_braces; my @bad_names; my @bad_titles; my %bad_keywords; my %bad_mandatory_tags; my %bad_unique_tags; ## Create hash all_tags with all tags found in mandatory_tags ## and unique_tags. my %all_tags; foreach my $tag (@mandatory_tags, @unique_tags) { $all_tags{$tag}++; } foreach my $file (@Rd_files) { ## Call the Rd preprocessor first. my $text = &Rdpp($file, $R::Vars::OSTYPE); ## And split into lines again. my @lines = split(/\n/, $text); ## Check tags and keywords. my %keywords; my %tagcount; foreach my $line (@lines) { foreach my $tag (keys %all_tags) { if($line =~ /^\s*\\$tag\{/) { $tagcount{$tag}++; } } if($line =~ /^\s*\\keyword\{\s*([^}]*[^}\s])\s*\}.*/) { $keywords{$1} = 1; } } foreach my $tag (@mandatory_tags) { push(@{$bad_mandatory_tags{$tag}}, $file) unless ($tagcount{$tag} > 0); } foreach my $tag (@unique_tags) { push(@{$bad_unique_tags{$tag}}, $file) unless ($tagcount{$tag} <= 1); } foreach my $key (keys(%keywords)) { push(@{$bad_keywords{$file}}, $key) unless $standard_keywords{$key}; } ## Check name and title. ## Note that the code here is based on Rd::info(). ## (Not entirely safe ...) $text =~ /\\name\{\s*([^\}]+)\s*\}/s; push(@bad_names, $file) if($1 =~ /^\s*$/); $text =~ /\\title\{\s*([^\}]+)\s*\}/s; push(@bad_titles, $file) if($1 =~ /^\s*$/); ## Check for unbalanced braces. $text = ""; ## Get rid of the \alias entries as these may have ## unbalanced braces (Paren.Rd). foreach my $line (@lines) { $text .= "\n$line" unless ($line =~ /^\s*\\alias/); } $text .= "\n"; my $delimcurly = new Text::DelimMatch; $delimcurly->delim("\{", "\}"); $delimcurly->escape("\\"); $text =~ s/([^\\])%.*\n/$1\n/g; # ??? ## Now loop through matching pairs of braces. while($delimcurly->match($text)) { $text = $delimcurly->post_matched; } ## Get rid of trailing comments. $text =~ s/^%.*\n/\n/gs; $text =~ s/\n%.*\n/\n/gs; ## Anything left in $text means unbalanced. if(!($text =~ /^\s*$/)) { push(@bad_braces, $file); } } my $any = 0; my @msg_writing_Rd = ("See chapter 'Writing R documentation'", "in manual 'Writing R Extensions'.\n"); if($#bad_braces >= 0) { $log->error(); $log->print("Rd files with unbalanced braces:\n"); $log->print(" " . join("\n ", @bad_braces) . "\n"); $log->print(wrap("", "", ("Unbalanced braces are Rd syntax", "errors, and result in incorrect", "documentation.\n"))); exit(1); } if($#bad_names >= 0) { $log->error(); $log->print("Rd files with missing or empty '\\name':\n"); $log->print(" " . join("\n ", @bad_names) . "\n"); $log->print(wrap("", "", @msg_writing_Rd)); exit(1); } if($#bad_titles >= 0) { $log->error(); $log->print("Rd files with missing or empty '\\title':\n"); $log->print(" " . join("\n ", @bad_titles) . "\n"); $log->print(wrap("", "", @msg_writing_Rd)); exit(1); } my $any_missing_mandatory_tag = 0; foreach my $tag (@mandatory_tags) { if(exists $bad_mandatory_tags{$tag}) { $log->warning() unless $any; $any++; $any_missing_mandatory_tag++; $log->print("Rd files without '${tag}':\n"); $log->print(" " . join("\n ", @{$bad_mandatory_tags{$tag}}) . "\n"); } } if($any_missing_mandatory_tag) { $log->print("These tags are required in an Rd file.\n"); $log->print(wrap("", "", @msg_writing_Rd)); } my $any_duplicate_unique_tag = 0; foreach my $tag (@unique_tags) { if(exists $bad_unique_tags{$tag}) { $log->warning() unless $any; $any++; $any_duplicate_unique_tag++; $log->print("Rd files with duplicate '${tag}':\n"); $log->print(" " . join("\n ", @{$bad_unique_tags{$tag}}) . "\n"); } } if($any_duplicate_unique_tag) { $log->print("These tags must be unique in an Rd file.\n"); $log->print(wrap("", "", @msg_writing_Rd)); } if(keys(%bad_keywords)) { $log->warning() unless $any; $any++; $log->print("Rd files with non-standard keywords:\n"); foreach my $file (keys(%bad_keywords)) { $log->print(wrap(" ", " ", ("'$file':", @{$bad_keywords{$file}}, "\n"))); } $log->print(wrap("", "", ("Each '\\keyword' entry should specify", "one of the standard keywords", "(as listed in file 'KEYWORDS.db'", "in the 'doc' subdirectory", "of the R home directory).\n"))); $log->print(wrap("", "", @msg_writing_Rd)); } $log->result("OK") unless $any; } ## Check for undocumented objects. if(((-d "R") || (-d "data")) && (-d "man")) { $log->checking("for undocumented objects"); my $Rcmd = "library(tools)\n"; if($opt_install) { $Rcmd .= "undoc(package = \"${pkgname}\")\n"; } else { $Rcmd .= "undoc(dir = \"${pkgdir}\")\n"; } my @out = R_runR($Rcmd, "${R_opts} --quiet"); my @err = grep(/^Error/, @out); @out = grep(!/^\>/, @out); if($#err < 0) { if($#out >= 0) { $log->warning(); $log->print(join("\n", @out) . "\n"); } else { $log->result("OK"); } } else { $log->error(); $log->print(join("\n", @err) . "\n"); exit(1); } } ## Check for code/documentation mismatches. if($opt_codoc && (-d "R") && (-d "man")) { $log->checking("for code/documentation mismatches"); my $Rcmd = "library(tools)\n"; if($opt_install) { $Rcmd .= "codoc(package = \"${pkgname}\")\n"; } else { $Rcmd .= "codoc(dir = \"${pkgdir}\")\n"; } my @out = R_runR($Rcmd, "${R_opts} --quiet"); ## ## With the current heuristics codoc() may throw an error even ## though the documentation is valid. Change this when we know ## what must be valid R code, similar to the above for undoc(). @out = grep(!/^\>/, @out); if($#out >= 0) { $log->warning(); $log->print(join("\n", @out) . "\n"); } else { $log->result("OK"); } ## } ## Check whether all arguments shown in \usage are documented in ## \arguments. if(-d "man") { $log->checking("for undocumented arguments in \\usage"); my $Rcmd = "library(tools)\n"; if($opt_install) { $Rcmd .= "checkDocArgs(package = \"${pkgname}\")\n"; } else { $Rcmd .= "checkDocArgs(dir = \"${pkgdir}\")\n"; } my @out = R_runR($Rcmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { $log->warning(); $log->print(join("\n", @out) . "\n"); } else { $log->result("OK"); } } ## Check C sources/headers for CRLF line endings. ## ## 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. ## 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() { chop; if($_ =~ /\r$/) { push(@bad_files, $file); last; } } close(FILE); } if($#bad_files >= 0) { $log->warning(); $log->print("Found the following C sources/headers with " . "CRLF line endings:\n"); $log->print(" " . join("\n ", @bad_files) . "\n"); $log->print("ISO C requires LF line endings.\n"); } else { $log->result("OK"); } } chdir($pkgoutdir); ## Run the examples. if($opt_examples && (-d &file_path($library, $pkgname, "R-ex"))) { $log->creating("${pkgname}-Ex.R"); my $Rexdir = &file_path($library, $pkgname, "R-ex"); my $iszipped = 0; my $cmd; if(-e &file_path($Rexdir, "Rex.zip")) { $iszipped = 1; my $UNZIP = &R_getenv("R_UNZIPCMD", "unzip -q"); $cmd = join(" ", ("$UNZIP", &file_path($Rexdir, "Rex.zip"), " -d $Rexdir")); if(R_system($cmd)) { $log->error(); $log->print("Cannot extract examples from ZIP archive.\n"); exit(1); } } if($WINDOWS) { ## avoid Rcmd as line may be too long after expansion. $cmd = "perl ${R::Vars::R_HOME}/bin/massage-Examples ". "${pkgname} ${library}/${pkgname}/R-ex ". "> ${pkgname}-Ex.R"; } else { $cmd = join(" ", ("${R::Vars::R_CMD} perl", &file_path(${R::Vars::R_HOME}, "share", "perl", "massage-Examples.pl"), "${pkgname} ${Rexdir} > ${pkgname}-Ex.R")); } if(R_system($cmd)) { $log->error(); $log->print("Running massage-Examples to create " . "${pkgname}-Ex.R failed.\n"); exit(1); } if($iszipped) { unlink(&list_files_with_exts($Rexdir, "R")); } $log->result("OK"); $log->checking("examples"); if($opt_use_gct) { $cmd = "(echo 'gctorture(TRUE)'; cat ${pkgname}-Ex.R) " . "| ${R::Vars::R_EXE} ${R_opts} > ${pkgname}-Ex.Rout 2>&1"; } else { $cmd = "${R::Vars::R_EXE} ${R_opts} " . "< ${pkgname}-Ex.R > ${pkgname}-Ex.Rout 2>&1"; } if(R_system($cmd)) { $log->error(); $log->print("Running examples failed.\n"); exit(1); } $log->result("OK"); } ## Run the package-specific tests. if($opt_install && $opt_tests && (-d &file_path($pkgdir, "tests"))) { $log->checking("tests"); my $testsrcdir = &file_path($pkgdir, "tests"); my $testdir = &file_path($pkgoutdir, "tests"); if(!(-d $testdir)) { mkdir($testdir, 0755) or die "Error: cannot create directory '$testdir'\n"; } chdir($testdir); foreach my $file (&list_files($testsrcdir)) { copy($file, basename($file)); } my $makefiles = "-f " . &file_path(${R::Vars::R_HOME}, "share", "make", "tests.mk"); if($WINDOWS) { $makefiles = "-f ${R::Vars::R_HOME}/share/make/wintests.mk";} my $makevars = ""; if($WINDOWS && (-r "$testsrcdir/Makefile.win")) { $makefiles .= " -f $testsrcdir/Makefile.win"; } elsif(-r &file_path($testsrcdir, "Makefile")) { $makefiles .= " -f " . &file_path($testsrcdir, "Makefile"); } if($WINDOWS && (-r "$testsrcdir/Makevars.win")) { $makevars = " -f $testsrcdir/Makevars.win"; } elsif(-r &file_path($testsrcdir, "Makevars")) { $makevars = " -f " . &file_path($testsrcdir, "Makevars"); } else { open(MAKEVARS, "> Makevars"); print MAKEVARS "makevars = -f Makevars\n"; print MAKEVARS "srcdir = $testsrcdir\n"; ## at least windows does not pass env correctly to make print MAKEVARS "R_LIBS = $ENV{'R_LIBS'}\n"; print MAKEVARS "VPATH = \$(srcdir)\n\n"; print MAKEVARS "test-src-1 ="; foreach my $file (&list_files_with_exts($testdir, "R")) { print MAKEVARS "\\\n " . basename($file); } print MAKEVARS "\n"; print MAKEVARS "test-src-auto ="; foreach my $file (&list_files_with_exts($testdir, "Rin")) { $file =~ s/Rin$/R/; print MAKEVARS "\\\n " . basename($file); } print MAKEVARS "\n"; print MAKEVARS "USE_GCT = $opt_use_gct\n"; close(MAKEVARS); $makevars = " -f Makevars"; } print "\n"; if(R_system("${R::Vars::MAKE} $makefiles $makevars")) { $log->error(); exit(1); } chdir($pkgoutdir); $log->result("OK"); } chdir($pkgoutdir); if((-d &file_path($pkgdir, "inst", "doc")) && &list_files_with_type(&file_path($pkgdir, "inst", "doc"), "vignette")) { $log->checking(join("", ("package vignettes in '", &file_path("inst", "doc"), "'"))); my $any = 0; ## Do PDFs exist for all package vignettes? my @vignette_files = &list_files_with_type(&file_path($pkgdir, "inst", "doc"), "vignette"); my @bad_vignettes = (); foreach my $file (@vignette_files) { my $pdf_file = $file; $pdf_file =~ s/\.[[:alpha:]]+$/.pdf/; push(@bad_vignettes, $file) unless(-f $pdf_file); } if($#bad_vignettes >= 0) { $log->warning(); $any++; $log->print("Package vignettes without corresponding PDF:\n"); $log->print(" " . join("\n ", @bad_vignettes) . "\n"); } ## Can we run the code in the vignettes? if($opt_vignettes) { my $Rcmd = "library(tools)\n"; if($opt_install) { $Rcmd .= "checkVignettes(package=\"${pkgname}\", " . "lib.loc = \"$pkgoutdir\", " . "workdir=\"src\")\n"; } else { $Rcmd .= "checkVignettes(dir = \"${pkgdir}\")\n"; } my @out = R_runR($Rcmd, "${R_opts} --quiet"); @out = grep(!/^\>/, @out); if($#out >= 0) { $log->warning() unless($any); $any++; $log->print(join("\n", @out) . "\n"); } } $log->result("OK") unless($any); } ## Run LaTeX on the manual. if($opt_latex) { if(-d &file_path($library, $pkgname, "latex")) { $ENV{'TEXINPUTS'} = env_path(&file_path($R::Vars::R_HOME, "share", "texmf"), $ENV{'TEXINPUTS'}); $log->creating("${pkgname}-manual.tex"); open(MANUAL, "> ${pkgname}-manual.tex") or die("Error: cannot open file '${pkgname}-manual.tex'" . "for writing"); print MANUAL "\\documentclass\{article\}\n" . "\\usepackage[ae,hyper]\{Rd\}\n\\begin\{document\}\n"; my @tex_files = &list_files_with_exts(&file_path($library, $pkgname, "latex"), "tex"); foreach my $file (@tex_files) { open(FILE, "< $file") or die("Error: cannot open file '$file' for reading"); while() { print MANUAL $_; } close(FILE); } print MANUAL "\\end\{document\}\n"; close(MANUAL); $log->result("OK"); if($HAVE_LATEX) { $log->checking("${pkgname}-manual.tex"); ## ## We use \nonstopmode{} so that LaTeX really gives an ## error (and returns) if something is wrong, and all ## info goes to ${pkgname}-manual.log. ## We also suppress all output from running LaTeX. ## We could also write stdout to a tempfile and replay ## this in case of problems. But does this really help? my $cmd = "${R::Vars::LATEX}"; $cmd .= " '\\nonstopmode{}\\input{${pkgname}-manual.tex}'"; $cmd .= " >/dev/null"; $cmd .= " 2>&1" if($R::Vars::OSTYPE eq "unix"); ## 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 -o ${pkgname}-manual.dvi >/dev/null 2>&1"; $cmd .= " 2>&1" if($R::Vars::OSTYPE eq "unix"); $cmd .= " $pkgdir"; if(R_system($cmd)) { $log->error(); $log->print("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 exit 0; }