#! @PERL@ #-*- perl -*- ## Copyright (C) 2000-2007 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::Rd; use R::Utils; use R::Vars; use Text::DelimMatch; 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", "use-zip-help", "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", "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 $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" 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; } ## ## 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"; } ## ## This is the main loop over all packages to be packaged. foreach my $pkg (@ARGV) { my $is_bundle = 0; $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); } my @bundlepkgs; if($description->{"Contains"}) { $log->message("looks like '${pkgname}' is a package bundle"); $is_bundle = 1; $intname = $description->{"Bundle"}; @bundlepkgs = split(/\s+/, $description->{"Contains"}); foreach my $ppkg (@bundlepkgs) { $log->message("cleaning '$ppkg' in bundle '$pkgname'"); $log->setstars("**"); ## chdir($startdir); cleanup_pkg(&file_path("$pkgdir", "$ppkg"), $log); $log->setstars("*"); } foreach my $ppkg (@bundlepkgs) { $log->message("preparing '$ppkg' in bundle '$pkgname':"); $log->setstars("**"); ## chdir($startdir); prepare_pkg(&file_path("$pkgdir", "$ppkg"), $is_bundle, $description, $log); $log->setstars("*"); } foreach my $ppkg (@bundlepkgs) { $log->message("cleaning '$ppkg' in bundle '$pkgname'"); $log->setstars("**"); ## chdir($startdir); cleanup_pkg(&file_path("$pkgdir", "$ppkg"), $log); $log->setstars("*"); } rmtree("$libdir") if (-d "$libdir"); } else { $is_bundle = 0; ## chdir($startdir); $log->message("preparing '$pkg':"); $intname = $description->{"Package"}; prepare_pkg($pkgdir, $is_bundle, $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; ## ## For bundles, the .Rbuildignore mechanism is not consistent ## between build and check: the latter always works on a per ## package basis. if(-f &file_path($pkgdir, ".Rbuildignore")) { open(RBUILDIGNORE, &file_path($pkgdir, ".Rbuildignore")); while() { chomp; 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 /^GNUMakefile$/; 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 $_ && /^\.git$/); ## 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() { 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 (in each package for a bundle) 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"); } } if($is_bundle) { foreach $ppkg (@bundlepkgs) { &find_invalid_files(&file_path($pkgname, $ppkg)); chdir($tmpdir); } } else { &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"); if($is_bundle) { foreach my $ppkg (@bundlepkgs) { &fix_nonLF_in_source_files(&file_path($pkgname, $ppkg), $log); &fix_nonLF_in_make_files(&file_path($pkgname, $ppkg), $log); } } else { &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"); } } } if($is_bundle) { foreach my $ppkg (@bundlepkgs) { &fix_unneeded_dirs(&file_path($pkgname, $ppkg)); } } else { &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) { $log->print("WARNING: some HTML links may not be found\n"); $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"); } } elsif($is_bundle) { $binfilename = "${pkgname}_" . $description->{"Version"} . "_R_${R_platform}.tar"; my $filepath = &file_path($startdir, $binfilename); $cmd = join(" ", (&shell_quote_file_path(${R::Vars::R_EXE}), "CMD INSTALL -l", &shell_quote_file_path($libdir), "$INSTALL_opts", &shell_quote_file_path($srcdir))); if(R_system($cmd)) { $log->error("installation failed"); } chdir("$libdir"); copy(&file_path($pkgdir, "DESCRIPTION"), "DESCRIPTION"); R_system(join(" ", ("$tar -chf ", &shell_quote_file_path($filepath), @bundlepkgs, "DESCRIPTION"))); R_system(join(" ", ("$gzip -9f ", &shell_quote_file_path($filepath)))); chdir($startdir); $log->message("packaged bundle '$pkgname' as '$binfilename.gz'"); } 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 { $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"); $fh->print("Packaged: ", scalar(localtime()), "; ", $user_name, "\n"); $fh->close(); } sub prepare_pkg { my ($pkgdir, $in_bundle, $description, $log) = @_; my $pkgname = basename($pkgdir); &R::Utils::check_package_description($pkgdir, $pkgname, $log, $in_bundle, 0, 1); &cleanup_pkg($pkgdir, $log) if(!$in_bundle); ## 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; ## if we are in a bundle, need to install the whole bundle ## once. my $pkg_or_bundle_dir; if ($in_bundle) { $pkg_or_bundle_dir = dirname($pkgdir); if(-d "$libdir") { $doit = 0; } else { $log->message("installing the *bundle* to re-build vignettes"); mkdir("$libdir", 0755) or die "Error: cannot create directory '$libdir'\n"; } } else { $pkg_or_bundle_dir = $pkgdir; $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($pkg_or_bundle_dir))); } else { $cmd = join(" ", (&shell_quote_file_path(${R::Vars::R_EXE}), "CMD INSTALL -l", &shell_quote_file_path($libdir), &shell_quote_file_path($pkg_or_bundle_dir))); } 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") unless $in_bundle; $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 (if not in a bundle). &cleanup_pkg($pkgdir, $log) if(!$in_bundle); } } 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") { 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") { my $makefiles = "-f " . &shell_quote_file_path(&file_path(${R::Vars::R_HOME}, "etc", "Makeconf")); $makefiles .= " -f Makefile"; R_system("${R::Vars::MAKE} $makefiles clean"); } else { ## 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() { 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() { 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 STDERR <. END exit 0; }