#! @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 use Cwd; use File::Basename; use File::Copy; use File::Find; use File::Path; use Getopt::Long; use R::Dcf; use R::Utils; use R::Rd; use Text::DelimMatch; ## don't buffer output $| = 1; my $revision = ' $Revision: 1.47.4.4 $ '; 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 @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"); 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; 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"; my $OS = R_getenv("R_OSTYPE", "unix"); 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/Rcmd.$$"; 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(); if($WINDOWS) { $ENV{'R_LIBS'} = "$library;$R_LIBS"; } else { $ENV{'R_LIBS'} = "$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") || 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") || die "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 || die "Error: no packages were specified"; my $pkg; foreach $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; if($WINDOWS) { $ENV{'R_LIBS'} = "$library;$R_LIBS"; } else { $ENV{'R_LIBS'} = "$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) { 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"}); my $ppkg = ""; foreach $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). if($OS eq "unix") { $log->checking("for sufficient file permissions"); my @badfiles = (); my @excludepatterns = ("^.Rbuildignore\$", "\~\$", "\.swp\$", "^.*/\.#[^/]*\$", "^.*/#[^/]*#\$"); if(-f "./.Rbuildignore") { open(RBUILDIGNORE, "./.Rbuildignore"); while() { chop; push(@excludepatterns, $_); } close(RBUILDIGNORE); } sub findWrongPerms { my $filename = $File::Find::name; $filename =~ s/^[^\/]*\///; foreach $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(\&findWrongPerms, "."); 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); } $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"); my $key; foreach $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"); my $field; foreach $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"} =~ /\bR *\([^)]*\)/) { ## The `Depends' field is not required, and currently only R ## version dependencies are used, which must be of the form ## `R ($op $version)' with `$op' one of `<=' or `>='. $log->checking("DESCRIPTION Depends field"); $description->{"Depends"} =~ /\bR *\(([^) ]+) *([^) ]+)\)/; if((($1 eq "<=") || ($1 eq ">=")) && $2) { $log->result("OK"); } else { $log->warning(); $log->message(" malformed Depends field"); } } ## check usage of library.dynam (if any) if(-d "R") { $log->checking("R files for library.dynam"); # only need to check the installed file open Rfile, "< $library/$pkgname/R/$pkgname" || die "cannot open \`$library/$pkgname/R/$pkgname' for reading\n"; my $any = 0; while() { if(/library.dynam\(\"(.*?)\"/o) { my $arg = $1; if($arg =~ /\.so$/) { $any++; $log->error(" library.dynam used with extension \`.so'"); exit(1); } if($arg =~ /\.sl$/) { $any++; $log->error(" library.dynam used with extension \`.sl'"); exit(1); } if($arg =~ /\.dll$/) { $any++; $log->error(" library.dynam used with extension \`.dll'"); exit(1); } } } close Rfile; $log->result("OK") unless $any; } ## check R documentation files if(-d "man") { $log->checking("Rd files"); my @rdfiles; my @badfiles; while() { if(/) { if(/= 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 $tag; my %allTags; foreach $tag (@mandatoryTags, @uniqueTags) { $allTags{$tag}++; } foreach $rdfile (@rdfiles) { open RDFILE, "< $rdfile" || die "cannot open \`$rdfile' for reading\n"; my %keywords; my %tagcount; while() { my $line = $_; foreach $tag (keys %allTags) { if($line =~ /^\s*\\$tag/) { $tagcount{$tag}++; } } if($line =~ /^\s*\\keyword{\s*([^}]*[^}\s])\s*}.*/) { $keywords{$1} = 1; } } close RDFILE; foreach $tag (@mandatoryTags) { push(@{$badmandatory{$tag}}, $rdfile) unless $tagcount{$tag}>0; } foreach $tag (@uniqueTags) { push(@{$badunique{$tag}}, $rdfile) unless $tagcount{$tag}<=1; } foreach $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/, R::Rd::Rdpp($rdfile, $OS)); foreach $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 $tag (@mandatoryTags) { if(exists $badmandatory{$tag}) { $log->warning("") unless $any; $any++; $log->message(" Rd files without \`${tag}':"); $log->message(" " . join("\n ", @{$badmandatory{$tag}})); } } foreach $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 $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" || die "Cannot write to \`$Rcmd'\n"; print Rcmd "undoc(dir = \"${pkgdir}\")\n"; close Rcmd; system("${R_exe} ${R_opts} < ${Rcmd} > ${Rout}"); my @out; open Rout, "< $Rout"; while () {chomp; push(@out, $_);} close Rout; unlink($Rcmd); unlink($Rout); my @err = grep {s/^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(" " . 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" || die "Cannot write to \`$Rcmd'\n"; print Rcmd "codoc(dir = \"${pkgdir}\")\n"; close Rcmd; system("${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 {/^(\$| *\[|\t+|Multiple|Error)/} @out; ## Also, the `\t+' in the above is ugly, but needed to catch the ## pretty-printing in errorcall() for non-NULL call ... if($#out>=0) { $log->warning(); $log->print(join("\n", @out) . "\n"); } else { $log->result("OK"); } ## } chdir($pkgoutdir); ## run the examples if($opt_examples && <$library/$pkgname/R-ex/*.R>) { $log->creating("${pkgname}-Ex.R"); my $iszipped = 0; my $cmd; if(-e "${library}/${pkgname}/R-ex/R-ex.zip") { $iszipped = 1; system("unzip ${library}/${pkgname}/R-ex/R-ex.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/*.R ". "> ${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("could not create directory $testdir\n"); exit(1); } } chdir($testdir); while(<$testsrcdir/*>) { copy($_, basename($_)); } my $makefiles = "-f ${R_HOME}/share/make/tests.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 && (-d "$library/$pkgname/latex")) { if($WINDOWS) { $ENV{'TEXINPUTS'} = "$R_HOME/share/texmf;$ENV{'TEXINPUTS'}"; } else { $ENV{'TEXINPUTS'} = "$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"); } } } #********************************************************** sub Rsystem { my $cmd = $_[0]; if($WINDOWS) { open cfile, "> $cfile" || die "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; }