#! @PERL@
#-*- perl -*-

## Copyright (C) 2000-2008 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 at
## http://www.r-project.org/Licenses/

## 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::Utils;
use Text::Wrap;

## Don't buffer output.
$| = 1;

my $revision = ' $Rev$ ';
my $version;
my $name;
$revision =~ / ([\d\.]*) /;
$version = $1;
($name = $0) =~ s|.*/||;

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

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-data", "force", "no-vignettes");

if($WINDOWS) {
    die "Please set TMPDIR to a valid temporary directory\n"
	unless (-d ${R::Vars::TMPDIR});
    @known_options = ("help|h", "version|v", "binary", "no-docs",
		      "auto-zip", "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 $gzip = R_getenv("R_GZIPCMD", "gzip");
## The tar.exe in Rtools has --force-local by default, but this
## enables people to use Cygwin or MSYS tar.
my $tar_default = "tar";
$tar_default = "tar --force-local" if $WINDOWS;
my $tar = R_getenv("TAR", $tar_default);
my $libdir = R_tempfile("Rinst");

my $INSTALL_opts = "";
$INSTALL_opts .= " --use-zip-data" if $opt_use_zip_data;
$INSTALL_opts .= " --no-docs" if $opt_no_docs;
if($WINDOWS) {
    $INSTALL_opts .= " --auto-zip" if $opt_auto_zip;
}

## <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' only for '--binary' ignored\n";
}
## </FIXME>

## This is the main loop over all packages to be packaged.
foreach my $pkg (@ARGV) {
    $pkg =~ s/\/$//;
    ## Older versions used $pkg as absolute or relative to $startdir.
    ## This does not easily work if $pkg is a symbolic link.
    ## Hence, we now convert to absolute paths.
    chdir($startdir);
    chdir($pkg) or die "Error: cannot change to directory '$pkg'\n";
    ## (We could be nicer ...)
    my $pkgdir = R_cwd();
    my $pkgname = basename($pkgdir);
    my $intname;
    ## chdir($startdir);
    ## (Does not hurt, but should no longer be necessary.)

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

    my $description;
    $log->checking("for file '$pkg/DESCRIPTION'");
    if(-r &file_path($pkgdir, "DESCRIPTION")) {
	$description = new R::Dcf(&file_path($pkgdir, "DESCRIPTION"));
	$log->result("OK");
    }
    else {
	$log->result("NO");
	exit(1);
    }

    if($description->{"Bundle"}) {
	$log->message("looks like '${pkgname}' is a package bundle -- they are defunct");
	$log->error();
	exit(1);
    }

    $log->message("preparing '$pkg':");
    $intname = $description->{"Package"};
    prepare_pkg($pkgdir, $description, $log);

    ## chdir($startdir);

    $log->message("removing junk files");
    find(\&unlink_junk_files, $pkgdir);

    chdir(dirname($pkgdir));
    my $filename = "${intname}_" . $description->{"Version"} . ".tar";
    my $filepath = &file_path($startdir, $filename);
    R_system(join(" ",
                 ("$tar -chf",
                  &shell_quote_file_path($filepath),
                  "$pkgname")));
    my $tmpdir = R_tempfile("Rbuild");
    rmtree($tmpdir) if(-d $tmpdir);
    mkdir("$tmpdir", 0755)
       or die "Error: cannot create directory '$tmpdir'\n";
    chdir($tmpdir);
    ## was xhf, but there are no symbolic links here and that is invalid
    ## on FreeBSD, see http://www.freebsd.org/cgi/man.cgi?query=tar&apropos=0&sektion=0&manpath=FreeBSD+5.4-RELEASE+and+Ports&format=html
    R_system(join(" ",
                 ("$tar -xf",
                  &shell_quote_file_path($filepath))));

    my $exclude = R_tempfile("Rbuild-exclude");
    open(EXCLUDE, "> $exclude")
	or die "Error: cannot open file '$exclude' for writing\n";
    binmode EXCLUDE if $WINDOWS;
    if(-f &file_path($pkgdir, ".Rbuildignore")) {
	open(RBUILDIGNORE, &file_path($pkgdir, ".Rbuildignore"));
	while(<RBUILDIGNORE>) {
	    chomp;
	    s/\r$//;  # careless people get Windows files on other OSes
	    push(@exclude_patterns, $_) if $_;
	}
	close(RBUILDIGNORE);
    }
    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(-d $_ && /^CVS$/);
	print EXCLUDE "$File::Find::name\n" if(-d $_ && /^\.svn$/);
	print EXCLUDE "$File::Find::name\n" if(-d $_ && /^\.arch-ids$/);
	print EXCLUDE "$File::Find::name\n" if(-d $_ && /^\.bzr$/);
	print EXCLUDE "$File::Find::name\n" if(-d $_ && /^\.git$/);
	print EXCLUDE "$File::Find::name\n" if(-d $_ && /^\.hg$/);
	## some authors managed to create ..Rcheck as well as pkgname.Rcheck
	print EXCLUDE "$File::Find::name\n" if(-d $_ && /\.Rcheck$/);
	## some authors have problems with 'Read-and-delete-me'
	print EXCLUDE "$File::Find::name\n" if /^Read-and-delete-me$/;
	print EXCLUDE "$File::Find::name\n" if /^GNUMakefile$/;
	## Mac resource forks
	print EXCLUDE "$File::Find::name\n" if(/^\._/);
	## Mac Finder files
	print EXCLUDE "$File::Find::name\n" if(/^\.DS_Store$/);
	## Windows DLL resource file
	push(@exclude_patterns, "^src/" . $pkgname . "_res\\.rc");
	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 wildcard
		    ## 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";
		}
	    }
	}
    }
    find(\&find_exclude_files, "$pkgname");
    close(EXCLUDE);

    ## Remove exclude files.
    open(EXCLUDE, "< $exclude");
    while(<EXCLUDE>) {
	rmtree(glob($_));
    }
    close(EXCLUDE);
    unlink($exclude);
    unlink($filepath);
    ## Now correct the package name (PR#9266)
    if($pkgname ne $intname) {
	rename $pkgname, $intname
	    or die "Error: cannot rename directory to '$intname'\n";
	$pkgname = $intname;
    }
    ## Fix up man, R, demo inst/doc directories
    sub find_invalid_files {
	my ($dpath) = @_;
	my $Rcmd = "tools:::.check_package_subdirs(\"$dpath\", TRUE)\n";
	## We don't run this in the C locale, as we only require
	## certain filenames to start with ASCII letters/digits, and not
	## to be entirely ASCII.
	my @out = R_runR($Rcmd, "--vanilla --slave",
			 "R_DEFAULT_PACKAGES=NULL");
	@out = grep(!/^\>/, @out);
	if(scalar(@out) > 0) {
	    $log->message("excluding invalid files from '$dpath'");
	    $log->print(join("\n", @out) . "\n");
	}
    }
    &find_invalid_files($pkgname);
    chdir($tmpdir);

    ## 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"));
    $log->message("checking for LF line-endings in source and make files");
    &fix_nonLF_in_source_files($pkgname, $log);
    &fix_nonLF_in_make_files($pkgname, $log);

    sub empty_dir_check {
	if(-d $_) {
	    opendir(DIR, $_) or die "cannot open dir $File::Find::name: $!";
	    my @files = readdir(DIR);
	    closedir(DIR);
	    if (@files <= 2) {
		$log->print("WARNING: directory '$File::Find::name' is empty\n");
	    }
	}
    }

    $log->message("checking for empty or unneeded directories");
    find(\&empty_dir_check, "${pkgname}");

    sub fix_unneeded_dirs {
	my ($path) = @_;
	my $dir;
	foreach my $system_dir ("Meta", "R-ex", "chtml",
		       "help", "html", "latex") {
	    $dir = &file_path($path, $system_dir);
	    if(-d "$dir") {
		$log->print(wrap("", "  ",
				 ("WARNING: Removing directory '$dir'",
				  "which should only occur",
				  "in an installed package\n")
				 ));
		rmtree("$dir");
	    }
	}
    }

    &fix_unneeded_dirs($pkgname);

    ## Finalize.
    if($opt_binary) {
	$log->message("building binary distribution");
	chdir($startdir);
	if (!-d "$libdir") {
	    mkdir("$libdir", 0755)
		or die "Error: cannot create directory '$libdir'\n";
	}
	my $srcdir = &file_path($tmpdir, $pkgname);
	my $cmd;
	if($WINDOWS) {
	    $cmd = join(" ",
			("Rcmd.exe INSTALL -l",
			 &shell_quote_file_path($libdir),
			 "--build $INSTALL_opts",
			 &shell_quote_file_path($srcdir)));
	    if(R_system($cmd)) { $log->error("installation failed"); }
	} else {
	    $cmd = join(" ",
			(&shell_quote_file_path(${R::Vars::R_EXE}),
			 "CMD INSTALL -l",
			 &shell_quote_file_path($libdir),
			 "--build $INSTALL_opts",
			 &shell_quote_file_path($srcdir)));
	    if(R_system($cmd)) { $log->error("installation failed"); }
	}
    } else {
	## precaution for Mac OS X to omit resource forks
	$ENV{COPYFILE_DISABLE} = 1; # Leopard
	$ENV{COPY_EXTENDED_ATTRIBUTES_DISABLE} = 1; # Tiger
	$log->message("building '$filename.gz'");
	R_system(join(" ",
		      ("$tar -chf",
		       &shell_quote_file_path($filepath),
		       "$pkgname")));
	R_system(join(" ",
		      ("$gzip -9f",
		       &shell_quote_file_path($filepath))));
    }
    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");
    my @dt = R_runR("cat(format(Sys.time(), '', tz='UTC', usetz=TRUE))",
		    "--vanilla --slave", "R_DEFAULT_PACKAGES=NULL");
    $fh->print("Packaged: ", @dt, "; ", $user_name, "\n");
    $fh->close();
}


sub prepare_pkg {
    my ($pkgdir, $description, $log) = @_;

    my $pkgname = basename($pkgdir);

    &R::Utils::check_package_description($pkgdir, $pkgname, $log, 0, 1);

    &cleanup_pkg($pkgdir, $log);

    ## 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) {
	    my $doit = 1;
	    $log->message("installing the package to re-build vignettes");
	    mkdir("$libdir", 0755)
		or die "Error: cannot create directory '$libdir'\n";
	    my $cmd;
	    if($WINDOWS) {
		$cmd = join(" ",
			    ("Rcmd.exe INSTALL -l",
			     &shell_quote_file_path($libdir),
			     &shell_quote_file_path($pkgdir)));
	    } else {
		$cmd = join(" ",
			    (&shell_quote_file_path(${R::Vars::R_EXE}),
			     "CMD INSTALL -l",
			     &shell_quote_file_path($libdir),
			     &shell_quote_file_path($pkgdir)));
	    }
	    if($doit && R_system($cmd)) {
		$log->error();
		$log->print("Installation failed.\n");
		$log->print("Removing '$libdir'\n");
		rmtree($libdir);
		exit(1);
	    }
	    my $R_LIBS = $ENV{'R_LIBS'};
	    $ENV{'R_LIBS'} = env_path("$libdir", $R_LIBS);

	    $log->creating("vignettes");
	    my $Rcmd = "library(tools)\n";
	    $Rcmd .= "buildVignettes(dir = '.')\n";
	    my %result = R_run_R($Rcmd, "--vanilla --no-save --quiet");
	    rmtree("$libdir");
	    $ENV{'R_LIBS'} = $R_LIBS;
	    if($result{"status"}) {
		my @out = grep(!/^\>/, @{$result{"out"}});
		$log->error();
		$log->print(join("\n", @out) . "\n");
		exit(1);
	    }
	    else {
		$log->result("OK");
	    }

	    ## And finally, clean up again.
	    &cleanup_pkg($pkgdir, $log);
	}
    }

    1;
}

sub cleanup_pkg {
    my ($pkgdir, $log) = @_;

    my $pkgname = basename($pkgdir);

    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") {
		## FIXME: why not use 'Makefile' if Makefile.win does not exist?
		R_system("${R::Vars::MAKE} -f Makefile.win clean");
	    } else {
		if(-r "Makevars.win") {
		    my $makefiles = " -f " .
			&shell_quote_file_path(&file_path(${R::Vars::R_SHARE_DIR},
							  "make", "clean.mk"));
		    $makefiles .= " -f Makevars.win";
		    R_system("${R::Vars::MAKE} $makefiles clean");
		} elsif (-r "Makevars") {
		    my $makefiles = " -f " .
			&shell_quote_file_path(&file_path(${R::Vars::R_SHARE_DIR},
							  "make", "clean.mk"));
		    $makefiles .= " -f Makevars";
		    R_system("${R::Vars::MAKE} $makefiles clean");
		}
		foreach my $file (<*.o $pkgname.a $pkgname.dll $pkgname.def>) {
		    unlink($file);
		}
		rmtree("_libs") if (-d "_libs");
	    }
	} else {
	    my $makefiles = "-f " .
		&shell_quote_file_path(&file_path(${R::Vars::R_HOME},
						  "etc".$ENV{"R_ARCH"},
						  "Makeconf"));
	    if(-r "Makefile") {
		$makefiles .= " -f Makefile";
		R_system("${R::Vars::MAKE} $makefiles clean");
	    } else {
		if(-r "Makevars") {
		    ## ensure we do have a 'clean' target.
		    $makefiles .= " -f " .
			&shell_quote_file_path(&file_path(${R::Vars::R_SHARE_DIR},
							  "make", "clean.mk"));
		    $makefiles .= " -f Makevars";
		    R_system("${R::Vars::MAKE} $makefiles clean");
		}
		## Also cleanup possible Windows leftovers ...
		unlink((<*.o *.s[lo] *.dylib>,
			"$pkgname.a", "$pkgname.dll", "$pkgname.def"));
		rmtree(".libs") if (-d ".libs");
		rmtree("_libs") if (-d "_libs");
	    }
	}
    }

    chdir($pkgdir);
    if(!$WINDOWS && -x "./cleanup") {
	$log->message("running cleanup");
	R_system("./cleanup");
    }

    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 fix_nonLF_in_source_files {
    my ($pkgname, $log) = @_;

    if(-d "$pkgname/src") {
	my @src_files = &list_files_with_type("$pkgname/src",
					      "src_no_CRLF");
	foreach my $file (@src_files) {
	    my $has_nonLF = 0;
	    open(FILE, "< $file")
		or die "Error: cannot open '$file' for reading\n";
	    open(TFILE, "> $file.tmp")
		or die "Error: cannot open '$file.tmp' for writing\n";
            binmode(FILE); binmode(TFILE);	# for Windows
	    while(<FILE>) {
		chomp;
		$has_nonLF = 1 if $_ =~ /\r/;
		$_ =~ s/\r$//;
		# any remaining CRs are internal and so line endings.
		$_ =~ s/\r/\n/g;
		print TFILE "$_\n";
	    }
	    close(TFILE); close(FILE);
	    if ($has_nonLF) {
		$log->print("    file '$file' had non-LF line endings\n");
		unlink($file); # should not be necessary, but is on Windows
		rename("$file.tmp", $file)
		    or die "Error: cannot rename '$file.tmp'\n";
	    } else {
		unlink("$file.tmp");
	    }
	}
    }
}


sub fix_nonLF_in_make_files {
    my ($pkgname, $log) = @_;

    if(-d "$pkgname/src") {
	my $file;
	foreach my $f ("Makefile", "Makefile.in", "Makevars", "Makevars.in")  {
	    $file = "$pkgname/src/$f";
	    next unless -f "$file";
	    my $has_nonLF = 0;
	    open(FILE, "< $file")
		or die "Error: cannot open '$file' for reading\n";
	    open(TFILE, "> $file.tmp")
		or die "Error: cannot open '$file.tmp' for writing\n";
            binmode(FILE); binmode(TFILE);	# for Windows
	    while(<FILE>) {
		chomp;
		$has_nonLF = 1 if $_ =~ /\r/;
		$_ =~ s/\r$//;
		# any remaining CRs are internal and so line endings.
		$_ =~ s/\r/\n/g;
		print TFILE "$_\n";
	    }
	    close(TFILE); close(FILE);
	    if ($has_nonLF) {
		$log->print("    file '$file' had non-LF line endings\n");
		unlink("$file"); # should not be necessary, but is on Windows
		rename("$file.tmp", $file)
		    or die "Error: cannot rename '$file.tmp'\n";
	    } else {
		unlink("$file.tmp");
	    }
	}
    }
}


sub usage {
    print <<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 "  --auto-zip            " .
	    "select zipping of data based on size\n";
    }
    print <<END;
  --use-zip-data        collect data files in zip archive
  --no-docs             do not build and install documentation

Report bugs to <r-bugs\@r-project.org>.
END
    exit 0;
}