The R Project SVN R

#! @PERL@

#-*- perl -*-

# Copyright (C) 2000-2004 R Development Core Team

#

# This program is free software; you can redistribute it and/or modify

# it under the terms of the GNU General Public License as published by

# the Free Software Foundation; either version 2, or (at your option)

# any later version.

#

# This program is distributed in the hope that it will be useful, but

# WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	See the GNU

# General Public License for more details.

#

# A copy of the GNU General Public License is available via WWW at

# http://www.gnu.org/copyleft/gpl.html.	 You can also obtain it by

# writing to the Free Software Foundation, Inc., 59 Temple Place,

# Suite 330, Boston, MA  02111-1307  USA.

# Send any bug reports to r-bugs@r-project.org

## <FIXME>

## This is not portable: has Unix-style file paths and system().  (But

## we need to call tar/gzip and zip, respectively, so it is not clear

## how platform-independent the code can be.)

## </FIXME>

use Cwd;

use File::Basename;

use File::Compare;

use File::Find;

use File::Path;

use File::Copy;

use Getopt::Long;

use IO::File;

use R::Dcf;

use R::Logfile;

use R::Rd;

use R::Utils;

use R::Vars;

use Text::DelimMatch;

use Text::Wrap;

## don't buffer output

$| = 1;

my $revision = ' $Revision: 1.74 $ ';

my $version;

my $name;

$revision =~ / ([\d\.]*) /;

$version = $1;

($name = $0) =~ s|.*/||;

R::Vars::error("R_HOME", "R_CMD");

my $WINDOWS = ($R::Vars::OSTYPE eq "windows");

my @exclude_patterns = R::Utils::get_exclude_patterns();

my @known_options = ("help|h", "version|v", "binary", "no-docs",

		     "use-zip", "use-zip-help", "use-zip-data",

		     "force", "no-vignettes");

if($WINDOWS) {

    die "Please set TMPDIR to a valid temporary directory\n"

	unless (-e ${R::Vars::TMPDIR});

    @known_options = ("help|h", "version|v", "binary", "docs:s", "auto-zip",

		      "use-zip", "use-zip-help", "use-zip-data", 

		      "force", "no-vignettes");

}

GetOptions(@known_options) or usage();

R_version("R add-on package builder", $version) if $opt_version;

usage() if $opt_help;

## Use system default unless explicitly specified otherwise.

$ENV{"R_DEFAULT_PACKAGES"} = "";

my $startdir = R_cwd();

my $R_platform = R_getenv("R_PLATFORM", "unknown-binary");

my $tar = R_getenv("TAR", "tar");

my $INSTALL_opts = "";

$INSTALL_opts .= " --use-zip" if $opt_use_zip;

$INSTALL_opts .= " --use-zip-data" if $opt_use_zip_data;

$INSTALL_opts .= " --use-zip-help" if $opt_use_zip_help;

if($WINDOWS) {

    $INSTALL_opts .= " --docs=$opt_docs" if $opt_docs;

    $INSTALL_opts .= " --auto-zip" if $opt_auto_zip;

} else {

    $INSTALL_opts .= " --no-docs" if $opt_no_docs;

}

## <FIXME>

## Once we have a 'global' log file, use $log->warning() instead of just

## print().

if(!$opt_binary && $INSTALL_opts ne "") {

    print "** Options '$INSTALL_opts' for '--binary' ignored\n";

}

## </FIXME>

## This is the main loop over all packages to be checked.

foreach my $pkg (@ARGV) {

    my $is_bundle = 0;

    $pkg =~ s/\/$//;

    my $pkgname = basename($pkg);

    chdir($startdir);

    my $log = new R::Logfile();

    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($opt_binary) {

	my $libdir = "${R::Vars::TMPDIR}/Rbuild.$$";

	mkdir("$libdir", 0755)

	    or die "Cannot create directory '$libdir'\n";

	if(R_system("${R::Vars::R_CMD} INSTALL -l '$libdir' " .

		    "$INSTALL_opts '$pkg'")) {

	    $log->error("installation failed");

	}

	print("\n");

	chdir($libdir);

	my $pkgs = $pkgname;

	## JG:  topLevelFiles will be files that sit in the top level of

	## a zip/tarball along with any included directories.

	my $topLevelFiles;

	if($description->{"Contains"}) {

	    $log->message("looks like '${pkg}' is a package bundle");

	    $is_bundle = 1;

	    my @bundlepkgs = split(/\s+/, $description->{"Contains"});

	    $pkgs = join(" ", @bundlepkgs);

	    ## JG: Get a copy of the bundle's DESCRIPTION file and add

	    ## it into the zip archive.

	    $log->message("copying $pkg/DESCRIPTION");

	    copy("$startdir/$pkg/DESCRIPTION", "DESCRIPTION");

	    $topLevelFiles = "DESCRIPTION";

	}

	if($WINDOWS) {

	    my $filename = "${pkgname}_" . $description->{"Version"};

	    $log->message("building '$filename.zip'");

	    R_system("rm -f $startdir/$filename.zip");

	    R_system("zip -r9X $startdir/$filename.zip " .

		     "$pkgs $topLevelFiles");

	    chdir($startdir);

	} else {

	    ## <FIXME>

	    ## As R CMD INSTALL recursively copies all of 'inst', we at

	    ## least need to make sure that CVS subdirs are excluded.

	    ## It is not clear whether more patterns should be excluded,

	    ## and we also need to fix this under Windows.

	    my $exclude = "${R::Vars::TMPDIR}/Rbuild-exclude.$$";

	    open(EXCLUDE, "> $exclude")

		or die "Cannot write to '$exclude'\n";

	    sub findExcludeFiles {

		print EXCLUDE "$File::Find::name\n" if /^CVS$/;

	    }

	    foreach my $p (split(/\s+/, $pkgs)) {

		find(\&findExcludeFiles, "$p");

	    }

	    close(EXCLUDE);

	    my $filename = "${pkgname}_" . $description->{"Version"} .

		"_R_${R_platform}.tar";

	    $log->message("building '$filename.gz'");

	    system("$tar chXf $exclude $startdir/$filename " .

		   "$pkgs $topLevelFiles");

	    chdir($startdir);

	    system("gzip -9f $filename");

	    unlink($exclude);

	    ## </FIXME>

	}

	rmtree($libdir);

    }

    else {

	if($description->{"Contains"}) {

	    $log->message("looks like '${pkg}' is a package bundle");

	    $is_bundle = 1;

	    my @bundlepkgs = split(/\s+/, $description->{"Contains"});

	    foreach my $ppkg (@bundlepkgs) {

		$log->message("preparing '$ppkg' in bundle '$pkg':");

		$log->setstars("**");

		chdir($startdir);

		prepare_pkg("$pkg/$ppkg", $is_bundle, $description, $log);

		$log->setstars("*");

	    }

	}

	else {

	    $is_bundle = 0;

	    chdir($startdir);

	    $log->message("preparing '$pkg':");

	    prepare_pkg("$pkg", $is_bundle, $description, $log);

	}

	chdir($startdir);

	$log->message("removing junk files");

	find(\&deleteJunkFiles, $pkg);

	my $exclude = "${R::Vars::TMPDIR}/Rbuild-exclude.$$";

	open(EXCLUDE, "> $exclude")

	  or die "Cannot write to '$exclude'\n";

	binmode EXCLUDE if $WINDOWS;

	## <NOTE>

	## For bundles, the .Rbuildignore mechanism is not consistent

	## between build and check: the latter always works on a per

	## package basis.  Maybe fix this once we know whether we want

	## to keep bundles ...

	if(-f "$pkg/.Rbuildignore") {

	    open(RBUILDIGNORE, "$pkg/.Rbuildignore");

	    while(<RBUILDIGNORE>) {

		chop;

		push(@exclude_patterns, $_) if $_;

	    }

	    close(RBUILDIGNORE);

	}

	## </NOTE>

	sub findExcludeFiles {

	    print EXCLUDE "$File::Find::name\n" if(-d $_ && /^check$/);

	    print EXCLUDE "$File::Find::name\n" if(-d $_ && /^chm$/);

	    print EXCLUDE "$File::Find::name\n" if(-d $_ && /[Oo]ld$/);

	    print EXCLUDE "$File::Find::name\n" if /^GNUMakefile$/;

	    print EXCLUDE "$File::Find::name\n" if /^CVS$/;

	    if($WINDOWS) {

		## exclude stray dependency files

		print EXCLUDE "$File::Find::name\n" if /\.d$/;

		print EXCLUDE "$File::Find::name\n" if /^Makedeps$/;

	    }

	    my $filename = $File::Find::name;

	    $filename =~ s/^[^\/]*\///;

	    foreach my $p (@exclude_patterns) {

		if($WINDOWS) {

		    ## Argh: Windows is case-honoring but not

		    ## case-insensitive ...

		    print EXCLUDE "$File::Find::name\n"

			if($filename =~	/$p/i);

		}

		else {

		    if($filename =~ /$p/) {

			## Seems that the Tar '-X' option uses exclude

                        ## *shell* patterns, where '*', '?', and '[...]'

                        ## are the usual shell wildcards and '\' escapes

			## them.  Hence we need to escape the wildchard

			## characters in file names.  On Windows, the

			## first two are invalid (and hence rejected by

			## R CMD check), and the last two do not need

			## escaping.

			$filename = "$File::Find::name";

			$filename =~ s/\[/\\\[/g;

			$filename =~ s/\]/\\\]/g;

			print EXCLUDE "$filename\n";

		    }

		}

	    }

	}

	chdir("$pkg/..");

	find(\&findExcludeFiles, "$pkgname");

	close(EXCLUDE);

	my $filename = "${pkgname}_" . $description->{"Version"} . ".tar";

	$log->message("building '$filename.gz'");

	my $filepath = "$startdir/$filename";

	if($WINDOWS) {

	    ## workaround for paths in Cygwin tar

	    $filepath =~ s+^([A-Za-x]):+/cygdrive/\1+;

	}

	## <FIXME>

	## Is option '-h' portable?

	R_system("$tar chf $filepath $pkgname");

	## </FIXME>

	my $tmpdir = "${R::Vars::TMPDIR}/Rbuild.$$";

	## (Same as $libdir for building a binary package.)

	rmtree($tmpdir) if(-d $tmpdir);

	mkdir("$tmpdir", 0755)

	    or die "Cannot create directory '$tmpdir'\n";

	chdir($tmpdir);

	R_system("$tar xhf $filepath");

	## Remove exclude files.

	open(EXCLUDE, "< $exclude");

	while(<EXCLUDE>) {

	    rmtree(glob($_));

	}

	close(EXCLUDE);

	unlink($exclude);

	## Fix permissions.

	sub fix_permissions {

	    ## Note that when called via File::Find::find, $_ holds the

	    ## file name within the current directory.

	    if(-d $_) {

		## Directories should really be mode 00755 if possible.

		chmod(00755, $_);

	    }

	    elsif(-f $_) {

		## Files should be readable by everyone, and writable

		## only for user.  This leaves a bit of uncertainty

		## about the execute bits.

		chmod(((stat $_)[2] | 00644) & 00755, $_);

	    }

	}

	find(\&fix_permissions, "${pkgname}") if(!$WINDOWS);

	## Add build stamp to the DESCRIPTION file.

	my @lines = &read_lines(&file_path($pkgname, "DESCRIPTION"));

	@lines = grep(!/^\s*$/, @lines); # Remove blank lines.

	my $user_name;

	if($WINDOWS) {

	    $user_name = Win32::LoginName();

	}

	else {

	    $user_name = (getpwuid($<))[0];

	}

	my $fh = new IO::File(&file_path($pkgname, "DESCRIPTION"), "w");

	$fh->print(join("\n", @lines), "\n");

	$fh->print("Packaged: ",

		   scalar(localtime()), "; ",

		   $user_name, "\n");

	$fh->close();

	## Finalize.

	R_system("$tar chf $filepath $pkgname");

	chdir($startdir);

	rmtree($tmpdir);

	R_system("gzip -9f $filename");

    }

    $log->close();

    print("\n");

}

sub prepare_pkg {

    my ($pkg, $in_bundle, $description, $log) = @_;

    chdir($pkg);

    my $pkgdir = R_cwd();

    my $pkgname = basename($pkg);

    if(-d "src") {

	chdir("src");

	$log->message("cleaning src");

	if($WINDOWS) {

	    ## a Windows Makefile.win might use $(RHOME)/src/gnuwin32/MkRules

	    $ENV{RHOME} = $ENV{R_HOME};

	    if(-r "Makefile.win") {

		R_system("${R::Vars::MAKE} -f Makefile.win clean");

	    } else {

		foreach my $file (<*.o $pkgname.a $pkgname.dll $pkgname.def>) {

		    unlink($file);

		}

		rmtree("_libs") if (-d "_libs");

	    }

	} else {

	    if(-r "Makefile") {

		system("${R::Vars::MAKE} -f Makefile clean");

	    } else {

		foreach my $file (<*.o *s[lo]>) {

		    unlink($file);

		}

		rmtree(".libs") if (-d ".libs");

	    }

	}

    }

    chdir($pkgdir);

    if(!$WINDOWS && -x "./cleanup") {

	$log->message("running cleanup");

	system("./cleanup");

    }

    ## Only update existing INDEX files.

    &updateRdIndex("INDEX", "man", $log) if(-f "INDEX");

    if((-d &file_path("inst", "doc"))

       && &list_files_with_type(&file_path("inst", "doc"),

				"vignette")) {

	if(!$opt_no_vignettes) {

	    $log->creating("vignettes");

	    my $Rcmd = "library(tools)\n";

	    $Rcmd .= "buildVignettes(dir = '.')\n";

	    my @out = R_runR($Rcmd, "--vanilla --no-save --quiet");

	    my @err = grep(/^Error/, @out);

	    if($#err >= 0) {

		@out = grep(!/^\>/, @out);

		$log->error();

		$log->print(join("\n", @out) . "\n");

		exit(1);

	    }

	    else {

		$log->result("OK");

	    }

	}

    }

    1;

}

sub deleteJunkFiles {

    unlink($_) if /^(\.RData|\.Rhistory)$/;

    if(/^DESCRIPTION$/) {

	unlink($_) if (-f "DESCRIPTION.in");

    }

}

sub updateIndex {

    my ($oldindex, $newindex, $log) = @_;

    $log->checking("whether '$oldindex' is up-to-date");

    if(-r $oldindex) {

	if(compare($oldindex, $newindex) != 0) {

	    $log->result("NO");

	    if($opt_force) {

		$log->message("overwriting '${oldindex}' as " .

			      "'--force' was given");

		unlink $oldindex;

		rename($newindex, $oldindex);

	    }

	    else {

		$log->message("use '--force' to overwrite " .

			      "the existing '${oldindex}'");

		unlink $newindex;

	    }

	}

	else {

	    $log->result("OK");

	    unlink $newindex;

	}

    }

    else {

	$log->result("NO");

	$log->message("creating new '$oldindex'");

	unlink $oldindex;

	rename($newindex, $oldindex);

    }

    1;

}

sub updateRdIndex {

    my ($oldindex, $Rdfiles, $log) = @_;

    my $newindex = ".Rbuildindex.$$";

    my $Rcmd = "Rdindex(\"${Rdfiles}\", \"${newindex}\")\n";

    my %result = 

	R_run_R($Rcmd, "--vanilla --quiet", "R_DEFAULT_PACKAGES=tools");

    if($result{"status"}) {

	## This is a bit silly ... but just in case this fails, we want

	## a decent error message.

	my @out = grep(!/^\>/, @{$result{"out"}});

	$log->message("computing Rd index");

	$log->error();

	$log->print(join("\n", @out) . "\n");

	exit(1);

    }

    updateIndex($oldindex, $newindex, $log);

    1;

}

sub usage {

    print STDERR <<END;

Usage: R CMD $name [options] pkgdirs

Build R packages from package sources in the directories specified by

pkgdirs. 

Options:

  -h, --help		print short help message and exit

  -v, --version		print version info and exit

  --force               force overwriting of INDEX file

  --no-vignettes        do not rebuild package vignettes

  --binary              build pre-compiled binary packages, with options:

END

    if($WINDOWS) {

	print STDERR "  --docs=TYPE           " .

	    "type(s) of documentation to build and install\n";

	print STDERR "  --auto-zip            " .

	    "select zipping of data and help based on size\n";

    } else {

	print STDERR "  --no-docs             " .

	    "do not build and install documentation\n";

    }

    print STDERR <<END;

  --use-zip-data        collect data files in zip archive

  --use-zip-help        collect help and examples into zip archives

  --use-zip             combine '--use-zip-data' and '--use-zip-help'

Email bug reports to <r-bugs\@r-project.org>.

END

    exit 0;

}