#! @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

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.81 $ ';
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 &file_path($pkg, "DESCRIPTION")) {
	$description = new R::Dcf(&file_path($pkg, "DESCRIPTION"));
	$log->result("OK");
    }
    else {
	$log->result("NO");
	exit(1);
    }

    if($opt_binary) {
	my $libdir = &file_path(${R::Vars::TMPDIR}, "Rbuild.$$");
	mkdir("$libdir", 0755)
	    or die "Error: cannot create directory '$libdir'\n";

	if(R_system(join(" ",
			 ("${R::Vars::R_CMD} INSTALL -l",
			  &shell_quote_file_path($libdir),
			  "$INSTALL_opts",
			  &shell_quote_file_path($pkg))))) {
	    $log->error("installation failed");
	}
	print("\n");
	chdir($libdir);

	my $pkgs = $pkgname;
	## JG: top_level_files will be files that sit in the top level
	## of a zip/tarball along with any included directories.
	my $top_level_files;
	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(&file_path($startdir, $pkg, "DESCRIPTION"),
		 "DESCRIPTION");
	    $top_level_files = "DESCRIPTION";
	}

	my $filename;
	if($WINDOWS) {
	    $filename = "${pkgname}_" . $description->{"Version"};
	    $log->message("building '$filename.zip'");
	    unlink(&file_path($startdir, "$filename.zip"));
	}
	else {
	    $filename = "${pkgname}_" . $description->{"Version"} .
		"_R_${R_platform}.tar";
	    $log->message("building '$filename.gz'");
	}
	## <FIXME>
	## As R CMD INSTALL recursively copies all of 'inst', we at
	## least need to make sure that CVS and .svn subdirs are
	## excluded.
	## It is not clear whether more patterns should be excluded,
	my $exclude =
	    &file_path(${R::Vars::TMPDIR}, "Rbuild-exclude.$$");
	open(EXCLUDE, "> $exclude")
	    or die "Error: cannot open file '$exclude' for writing\n";
	sub find_exclude_files {
	    print EXCLUDE "$File::Find::name\n" if(-d $_ && /^CVS$/);
	    print EXCLUDE "$File::Find::name\n" if(-d $_ && /^\.svn$/);
	}
	foreach my $p (split(/\s+/, $pkgs)) {
	    find(\&find_exclude_files, "$p");
	}
	close(EXCLUDE);
	## Remove exclude files.
	open(EXCLUDE, "< $exclude");
	while(<EXCLUDE>) {
	    rmtree($_);
	}
	close(EXCLUDE);
	unlink($exclude);
	## </FIXME>

	## <NOTE>
	## We maybe should add some build stamps as well ...
	## (But not just 'Packaged', as then binary packages created
	## from source packages would record conflicting data.)
	## </NOTE>

	my $filepath = &file_path($startdir, $filename);
	if($WINDOWS) {
	    R_system(join(" ",
			  ("zip -r9X",
			   &shell_quote_file_path($filepath.".zip"),
			   "$pkgs $top_level_files")));
	}
	else {
	    R_system(join(" ",
			  ("$tar chf ",
			   &shell_quote_file_path($filepath),
			   "$pkgs $top_level_files")));
	    R_system(join(" ",
			  ("gzip -9f ",
			   &shell_quote_file_path($filepath))));
	}

	chdir($startdir);
	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(&file_path("$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(\&unlink_junk_files, $pkg);

	my $exclude =
	    &file_path(${R::Vars::TMPDIR}, "Rbuild-exclude.$$");
	open(EXCLUDE, "> $exclude")
	  or die "Error: cannot open file '$exclude' for writing\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 &file_path($pkg, ".Rbuildignore")) {
	    open(RBUILDIGNORE, &file_path($pkg, ".Rbuildignore"));
	    while(<RBUILDIGNORE>) {
		chop;
		push(@exclude_patterns, $_) if $_;
	    }
	    close(RBUILDIGNORE);
	}
	## </NOTE>
	sub find_exclude_files {
	    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(-d $_ && /^CVS$/);
	    print EXCLUDE "$File::Find::name\n" if(-d $_ && /^\.svn$/);
	    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(&file_path("$pkg", ".."));
	find(\&find_exclude_files, "$pkgname");
	close(EXCLUDE);

	my $filename = "${pkgname}_" . $description->{"Version"} . ".tar";
	$log->message("building '$filename.gz'");
	my $filepath = &file_path($startdir, $filename);
	## under Windows, need separate Cygwin and Windows versions.
	my $origfilepath = $filepath;
	if($WINDOWS) {
	    ## workaround for paths in Cygwin tar
	    $filepath =~ s+^([A-Za-x]):+/cygdrive/\1+;
	}
	R_system(join(" ",
		      ("$tar chf",
		       &shell_quote_file_path($filepath),
		       "$pkgname")));
	my $tmpdir = &file_path(${R::Vars::TMPDIR}, "Rbuild.$$");
	## (Same as $libdir for building a binary package.)
	rmtree($tmpdir) if(-d $tmpdir);
	mkdir("$tmpdir", 0755)
	    or die "Error: cannot create directory '$tmpdir'\n";
	chdir($tmpdir);
	R_system(join(" ",
		      ("$tar xhf",
		       &shell_quote_file_path($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.
	&add_build_stamp_to_description_file(&file_path($pkgname,
							"DESCRIPTION"));
	## Finalize.
	R_system(join(" ",
		      ("$tar chf",
		       &shell_quote_file_path($filepath),
		       "$pkgname")));
	R_system(join(" ",
		      ("gzip -9f",
		       &shell_quote_file_path($origfilepath))));
	
	chdir($startdir);
	rmtree($tmpdir);
    }
    $log->close();
    print("\n");
}


sub add_build_stamp_to_description_file {
    my ($dpath) = @_;
    
    my @lines = &read_lines($dpath);
    @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($dpath, "w")
	or die "Error: cannot open file '$dpath' for writing\n";
    ## Do not keep previous build stamps.
    @lines = grep(!/^Packaged:/, @lines); 
    $fh->print(join("\n", @lines), "\n");
    $fh->print("Packaged: ",
	       scalar(localtime()), "; ",
	       $user_name, "\n");
    $fh->close();
}


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") {
		R_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");
	R_system("./cleanup");
    }

    ## Only update existing INDEX files.
    &update_Rd_index("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(scalar(@err) > 0) {
		@out = grep(!/^\>/, @out);
		$log->error();
		$log->print(join("\n", @out) . "\n");
		exit(1);
	    }
	    else {
		$log->result("OK");
	    }
	}
    }

    1;
}

sub unlink_junk_files {
    unlink($_) if /^(\.RData|\.Rhistory)$/;
    if(/^DESCRIPTION$/) {
	unlink($_) if (-f "DESCRIPTION.in");
    }
}


sub update_index {
    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 update_Rd_index {
    my ($oldindex, $Rd_files, $log) = @_;

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

    my $Rcmd = "Rdindex(\"${Rd_files}\", \"${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);
    }

    update_index($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;
}