The R Project SVN R

#! @PERL@
#-*- perl -*-
# Copyright (C) 2000-2003 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 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.66 $ ';
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;

my $startdir = 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(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'");
        system("rm -f $startdir/$filename.zip");
        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?
    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);
    system("$tar xhf $filepath");
    open(EXCLUDE, "< $exclude");
    while(<EXCLUDE>) {
        rmtree(glob($_));
    }
    close(EXCLUDE);
    ## unlink($exclude);    
    system("$tar chf $filepath $pkgname");
    rmtree($tmpdir);
    chdir($startdir);
    system("gzip -9f $filename");
    }
    $log->close();
    print("\n");
}



sub prepare_pkg {

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

    chdir($pkg);
    my $pkgdir = 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") {
        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");
    }

    &updateRdIndex("INDEX", "man", $log);

    if((-d &file_path("inst", "doc"))
       && &list_files_with_type(&file_path("inst", "doc"),
                "vignette")) {
    if(!$opt_no_vignettes) {
        $log->creating("vignettes");
        my $Rcmd = "buildVignettes(dir = '.')\n";
        my @out = R_runR($Rcmd, "--vanilla --no-save --quiet",
                 "R_DEFAULT_PACKAGES=tools");
        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";

    ## <FIXME>
    ## What if this fails?
    R_runR($Rcmd, "--vanilla --quiet", "R_DEFAULT_PACKAGES=tools");
    ## </FIXME>

    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;
}