#! @PERL@ #-*- perl -*- # Copyright (C) 2000 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@lists.r-project.org use Cwd; use File::Basename; use File::Path; use Getopt::Long; use R::Dcf; use R::Utils; ## don't buffer output $|=1; my $revision = ' $Revision: 1.3.6.1 $ '; my $version; my $name; $revision =~ / ([\d\.]*) /; $version = $1; ($name = $0) =~ s|.*/||; my $LATEX = '@LATEX@'; my $MAKE = '@MAKE@'; $opt_clean = $opt_examples = $opt_tests = $opt_latex = 1; my @knownoptions = ("help|h", "version|v", "outdir|o:s", "nsize:s", "vsize:s", "library|l:s", "clean!", "examples!", "tests!", "latex!"); GetOptions (@knownoptions) || usage(); R_version($name, $version) if $opt_version; usage() if $opt_help; my $startdir=getcwd(); $opt_outdir=$startdir unless $opt_outdir; chdir($opt_outdir) || die "Cannot change to directory $opt_outdir\n"; my $outdir=getcwd(); 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 $WINDOWS = R_getenv("R_UNDER_WINDOWS", 0); my $TMPDIR = R_getenv("TMPDIR", "/tmp"); my $R_exe = "${R_HOME}/bin/R"; if($WINDOWS){ $TMPDIR = R_getenv("TMPDIR", "/TEMP"); $R_exe = "Rterm.exe"; $MAKE = "make"; $LATEX = "latex"; } my $R_LIBS = $ENV{'R_LIBS'}; my $library; if($opt_library){ chdir($opt_library) || die "Error: cannot change to directory \`$opt_library'\n"; $library=getcwd(); if($WINDOWS){ $ENV{'R_LIBS'} = "$library;$R_LIBS"; } else{ $ENV{'R_LIBS'} = "$library:$R_LIBS"; } chdir($startdir); } my $R_opts = "--vanilla"; $R_opts .= " --nsize=$opt_nsize" if $opt_nsize; $R_opts .= " --vsize=$opt_vsize" if $opt_vsize; if($opt_latex){ my $log = new R::Logfile(); $log->checking("for working latex"); open(texfile, "> $TMPDIR/Rtextest$$.tex") || die "cannot write to Rtextest$$.tex\n"; print texfile "\\documentclass\{article\}\\begin\{document\}" . "test\\end\{document\}\n"; close texfile; chdir($TMPDIR); if(system("$LATEX Rtextest$$ > Rtextest$$.out")){ $log->result("NO"); $HAVE_LATEX=0; } else{ $log->result("OK"); $HAVE_LATEX=1; } unlink(); chdir($startdir); $log->close(); } ## this is the main loop over all packages to be checked my $pkg; $#ARGV <=1 || die "no packages were specified"; foreach $pkg (@ARGV){ my $is_bundle=0; $pkg =~ s/\/$//; my $pkgname = basename($pkg); chdir($startdir); my $pkgoutdir="$outdir/$pkgname.Rcheck"; rmtree($pkgoutdir) if ($opt_clean && (-d $pkgoutdir)) ; if(! -d $pkgoutdir){ if(! mkdir($pkgoutdir, 0755)){ die("could not 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"; } } print "\n"; if(system("${R_CMD} INSTALL -l $library $pkg")){ $log->error("installation failed"); } print("\n"); my $description; $log->checking("for file \`$pkg/DESCRIPTION'"); if(-r "$pkg/DESCRIPTION"){ $description = new R::Dcf("$pkg/DESCRIPTION"); $log->result("OK"); } else{ $log->result("NO"); exit(1); } if($description->{"Contains"}){ $log->message("Looks like \`${pkg}' is a package bundle"); $is_bundle=1; my @bundlepkgs = split(/\s+/, $description->{"Contains"}); my $ppkg=""; foreach $ppkg (@bundlepkgs){ $log->message("checking \`$ppkg' in bundle \`$pkg'"); $log->setstars("**"); chdir($startdir); check_pkg("$pkg/$ppkg", $pkgoutdir, $startdir, $library, $is_bundle, $description, $log); $log->setstars("*"); } } else{ $is_bundle=0; chdir($startdir); check_pkg("$pkg", $pkgoutdir, $startdir, $library, $is_bundle, $description, $log); } if($log->{"warnings"}){ print("\n") ; $log->summary(); } $log->close(); print("\n"); } #********************************************************** sub updateIndex { my ($oldindex, $Rdfiles) = @_; my $newindex = "$TMPDIR/Rcheck.$$"; system("${R_CMD} Rdindex ${Rdfiles} > ${newindex}"); my $diff = `diff -b $oldindex $newindex`; if($diff){ $log->result("NO"); if($opt_force){ $log->message("overwriting \`${oldindex}' as \`--force' was given"); rename($newindex, $oldindex); } else{ $log->message("use \`--force' to overwrite the existing \`${oldindex}'"); } } else{ $log->result("OK"); } unlink $newindex; } sub check_pkg { my ($pkg, $pkgoutdir, $startdir, $library, $in_bundle, $description, $log) = @_; my $pkgname = basename($pkg); $log->checking("package directory"); my $dir; if(-d $pkg){ chdir($pkg); $dir = getcwd(); } else{ $log->error("package dir \`${pkg}' does not exist"); 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); } } ## mandatory entries in DESCRIPTION: ## Package, Title, Version, License, Author $log->checking("DESCRIPTION Package entry"); if(! $description->{"Package"}){ $log->error("no DESCRIPTION Package entry found"); exit(1); } if($description->{"Package"} ne basename($dir)){ $log->error("DESCRIPTION Package field differs from dir name"); exit(1); } $log->result("OK"); my $entry; foreach $entry (qw(Title Version License Author)){ $log->checking("DESCRIPTION $entry entry"); if(! $description->{$entry}){ $log->error("no DESCRIPTION $entry entry found"); exit(1); } $log->result("OK"); } ## check Rd documentation files if(-d "man"){ $log->checking("Rd files"); my @rdfiles; my @badfiles; while(){ 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 %badmandatory; my %badunique; ## 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 %tagcount; while(){ my $line = $_; foreach $tag (keys %allTags) { if($line=~/^\s*\\$tag/){ $tagcount{$tag}++; } } } close rdfile; foreach $tag (@mandatoryTags){ push(@{$badmandatory{$tag}}, $rdfile) unless $tagcount{$tag}>0; } foreach $tag (@uniqueTags){ push(@{$badunique{$tag}}, $rdfile) unless $tagcount{$tag}<=1; } } my $any=0; 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}})); } } $log->result("OK") unless $any; } ## Check for undocumented objects if(-d "R" && -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 = \"${dir}\")\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); } } chdir($pkgoutdir); if($opt_examples && (-d "$library/$pkgname/R-ex")){ $log->creating("${pkgname}-Ex.R"); my $iszipped = 0; my $massage = "massage-Examples"; $massage .= ".sh" if($WINDOWS); 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(system("${R_CMD} ${massage} ". "${pkgname} ${library}/${pkgname}/R-ex/*.R ". "> ${pkgname}-Ex.R")){ $log->error(); exit(1); } if($iszipped) { unlink(<${library}/${pkgname}/R-ex/*.R>); } $log->result("OK"); $log->checking("examples"); if(system("${R_exe} ${R_opts} " . "< ${pkgname}-Ex.R > ${pkgname}-Ex.Rout")){ $log->error("running examples failed"); exit(1); } $log->result("OK"); } if($opt_tests && (-d "$startdir/$pkg/tests")){ my $testdir="$startdir/$pkg/tests"; $log->checking("tests"); my $makefiles="-f ${R_HOME}/etc/Makeconf-tests"; my $makevars=""; if($WINDOWS && (-r "$testdir/Makefile.win")){ $makefiles .= " -f $testdir/Makefile.win"; } elsif(-r "$testdir/Makefile"){ $makefiles .= " -f $testdir/Makefile"; } if($WINDOWS && (-r "$testdir/Makevars.win")){ $makevars = " -f $testdir/Makevars.win"; } elsif(-r "$testdir/Makevars"){ $makevars = " -f $testdir/Makevars"; } else{ open makevars, "> Makevars"; print makevars "makevars = -f Makevars\n"; print makevars "srcdir = $testdir\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"; close makevars; $makevars = " -f Makevars"; } print "\n"; if(system("$MAKE $makefiles $makevars")){ $log->error(); exit(1); } $log->result("OK"); } if($opt_latex && (-d "$library/$pkgname/latex")){ if($WINDOWS){ $ENV{'TEXINPUTS'}="$R_HOME/doc/manual;$ENV{'TEXINPUTS'}"; } else{ $ENV{'TEXINPUTS'}="$R_HOME/doc/manual:$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 $_; } } print manual "\\end\{document\}\n"; close manual; $log->result("OK"); if($HAVE_LATEX){ $log->checking("${pkgname}-manual.tex"); print "\n"; if(system("$LATEX ${pkgname}-manual")){ $log->error(); exit(1); } $log->result("OK"); } } } #********************************************************** sub usage { print STDERR <. END exit 0; }