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